<エクセルマクロ>データ群の並列(条件付き)

エクセルSheet2のA1~Anセル(nは変数)にある文字列(数値列混在)群を同一エクセルSheer1のX列のX1以下に貼り付けて積み下げていくマクロが欲しいです。X1~Xnセルに貼り付けたら、次はX(n+1)に同じものを貼り付けする。(Xについて、「貼りつける列はどこにしますか?」というメッセージボックスがでると幸いです。)
また、貼り付け作業は、X列の(αn+1)(αは正の整数で1、2、3、4、5、6と増えていく)を見て、空欄になるまで、データの貼り付けを続ける。
というマクロが希望です。
図示すると以下の様になります。

(例示)Sheet2のA1~Anセル(nは変数)にある文字列(数値列混在)群=x ,y,z (例は n=3)と仮定すると
マクロ実行前は、X列は空欄で、マクロ実行後は下記の様になるマクロ
X-1列,X列,   X+1列
a, x
a, y
a, z
~~途中略~~~
b, x
b, y
b, z
c, x
c, y
c, z
空欄    空欄(左のセルが空欄なのでここでストップ)

上記のようなマクロできますか?よろしくお願いいたします。

回答の条件
  • URL必須
  • 1人3回まで
  • 13歳以上
  • 登録:2010/10/09 17:44:29
  • 終了:2010/10/10 08:37:24

ベストアンサー

id:Ktwo No.1

Ktwo回答回数21ベストアンサー獲得回数52010/10/10 03:23:34

ポイント100pt

例示に合わせて作成してみやした。

Option Explicit

Dim sN              As String
Dim lN              As Long
Dim sColumn         As String
Dim sColumn_Left    As String
Dim lRow            As Long
Dim lCounter        As Long

Public Sub Macro1()
On Error GoTo Macro1_Error

Dim sColumn     As String

    sN = InputBox("変数nを指定して下さい?", "Sheet2のコピー元件数指定")
    lN = CLng(sN)
    
    sColumn = InputBox("貼りつける列はどこにしますか?", "列選択", "X")
    sColumn = UCase(sColumn)
    
    '入力チェック&左列決定
    If LenB(sColumn) < 2 Or LenB(sColumn) > 4 _
    Then
        MsgBox "Input Error 001": GoTo Macro1_Exit
    End If
    Select Case LenB(sColumn)
        Case 2
            If sColumn < "B" Or sColumn > "Z" _
            Then
                MsgBox "Input Error 002": GoTo Macro1_Exit
            End If
            sColumn_Left = Chr(Asc(sColumn) - 1)                    '<= 左列決定
        Case 4
            If MidB(sColumn, 1, 2) < "A" Or MidB(sColumn, 1, 2) > "Z" Or _
               MidB(sColumn, 3, 2) < "A" Or MidB(sColumn, 3, 2) > "Z" _
            Then
                MsgBox "Input Error 003": GoTo Macro1_Exit
            End If
            If MidB(sColumn, 3, 2) <> "A" _
            Then
                sColumn_Left = MidB(sColumn, 1, 2) _
                               & Chr(Asc(MidB(sColumn, 3, 2)) - 1)  '<= 左列決定
            Else
                If MidB(sColumn, 1, 2) <> "A" _
                Then
                    sColumn_Left = Chr(Asc(MidB(sColumn, 1, 2)) - 1) _
                                   & "Z"                            '<= 左列決定
                Else
                    sColumn_Left = "Z"                              '<= 左列決定
                End If
            End If
    End Select
    
    '積み下げ処理
    Sheets("Sheet1").Select
    lCounter = 0
    lRow = 1
    Do Until IsEmpty(Sheet1.Range(sColumn_Left & CStr(lRow)).Value)
    
        lCounter = lCounter + 1
        If lCounter > lN _
        Then
            lCounter = 1
        End If
    
        Sheet2.Range("A" & CStr(lCounter)).Copy
        Sheet1.Range(sColumn & CStr(lRow)).Select
        ActiveSheet.Paste
    
        lRow = lRow + 1
    
    Loop
    
Macro1_Exit:
    If Application.CutCopyMode = xlCopy _
    Then
        Application.CutCopyMode = False
    End If
    
    MsgBox "Finished"
    
    Exit Sub
    
Macro1_Error:

    MsgBox "!! ERROR !!" & vbCr & vbCr & Err.Description

End Sub

Cellsを使うと、左列決定が楽になると思いますが、

敢えて、Rangeのみで・・・~>°)mニニニニ=~

EXCELのオブジェクト(セルの指定)

http://homepage2.nifty.com/kasayan/vba/excel2.htm

id:hirohirohiro777

Ktwoさん

完璧なマクロで大変感謝感激です。

ありがとうございました。

2010/10/10 08:36:33
  • id:Ktwo
    イルカ頂きまして、ありがとうございますm(__)m
    Sub内の、Dim sColumn As Stringは不要ですね、
    ごめんなさい///

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません