EXCEL VBAで

質問

EXCEL VBAで

シート1のＡ２～Ｇ２までの列にＡ,B,C,D～と題名があり、それぞれの下の行には数字が並んでます。シート２のＡ２～Ｇ２までの列にもＡ,B,C,D～と題名がありますが、ランダムに並んでます。シート1のＡの行を、シート2のＡの行に、ＢにはＢへという風にコピーをさせるにはどのようにすればよいでしょうか。またシート1Ａ～Ｇのどれかが欠けている場合もあります。その場合はシート1にあるもののみコピーすることとします。

わかりにくいかも知れませんか、どうかよろしくお願いします。

回答No.3

tom04 · ベストアンサー

こんにちは！
参考になるかどうか判りませんが・・・

もしSheet1のデータ範囲が決まっているのであれば関数でも可能だと思います。
仮にSheet1の100行目までデータがあると仮定して、

Sheet2のA3セルに
=IF(INDEX(Sheet1!$A$3:$G$100,ROW(A1),MATCH(A$2,Sheet1!$A$2:$G$2,0))="","",INDEX(Sheet1!$A$3:$G$100,ROW(A1),MATCH(A$2,Sheet1!$A$2:$G$2,0)))

という数式をいれ、オートフィルで列方向と行方向にコピーではどうでしょうか？

尚、データ量が決まっていない場合はやはりVBAでの方法になると思います。
一例ですが、↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 1 To ws1.UsedRange.Columns.Count
For j = 1 To ws2.UsedRange.Columns.Count
For k = 3 To ws1.UsedRange.Rows.Count
If ws2.Cells(2, j) = ws1.Cells(2, i) Then
ws2.Cells(k, j) = ws1.Cells(k, i)
End If
Next k
Next j
Next i
End Sub

他に良いコードがあれば読み流してくださいね。m(__)m

お礼

ありがとうございます！

回答No.2

merlionXX

シート1にあるもののみコピーすることとしますということは、シート1にあるものならばシート2を上書きしてもいいんですよね？
こんな感じでいかが？

Sub test01()
　　Dim s(1 To 2) As Worksheet
　　Dim i As Integer, n As Integer
　　Set s(1) = Sheets("Sheet1")
　　Set s(2) = Sheets("Sheet2")
　　For i = 1 To 7
　　　　For n = 1 To 7
　　　　　　If s(1).Cells(2, i).Value = s(2).Cells(2, n).Value Then
　　　　　　　　s(1).Cells(2, i).EntireColumn.Copy s(2).Cells(2, n).EntireColumn
　　　　　　End If
　　　　Next n
　　Next i
End Sub

お礼

ありがとうございます！

回答No.1

m_and_dmp

こんなのはどうでしょう。
シート１の名前は"FROM"、シート２は"TO"としました。
"FROM"のデータは"A"列から始まらなくてもかまいませんが、行は"2"です。
タイトル列の数は100以下としました。
"FROM"のタイトルの並びはA,B,C...を想定していますが、ランダムでもかまいません。
"TO"のタイトルの並びはスペック通りランダムです。
どちらのシートもタイトルとタイトルの間に隙間があってもかまいません。
"FROM"のデータを"TO"のデータの最後の行の次以降にコピーされるようにしてあります。
（上書きをしません。上書きでかまわなければコードはグッとシンプルになります。）
データ行は、途中に抜け（空白）があってもかまいません。
以上の通り、柔軟に動くように作りましたが、必要がないところは適当に変更して試してください。ご希望があれば、修正します。

Sub Flexcopy()
k = 1
Do Until k = 100
Worksheets("FROM").Activate
With Worksheets("FROM")
For i = k To 100
TF = Cells(2, i).Value
If TF <> "" Then Exit For
Next
LRF = Cells(2, i).End(xlDown).Row
If LRF > 1000 Then GoTo EP
End With
Worksheets("TO").Activate
With Worksheets("TO")
For j = 1 To 100
TT = Cells(2, j).Value
If TT = TF Then Exit For
Next
LRT = Cells(2, j).End(xlDown).Row
If LRT > 1000 Then LRT = 1000
End With
Worksheets("FROM").Activate
Range(Cells(3, i), Cells(LRF, i)).Copy _
Destination:=Worksheets("TO").Cells(LRT + 1, j)
k = i + 1
Loop
EP:
Worksheets("TO").Activate

End Sub

お礼

ありがとうございます！