VBAで他のシートの特定の列を検索・コピーし、貼り付ける。

質問

お世話になります。
VBA初心者です、よろしくお願いいたします。
掲題にありますとおり、他のシートの特定の列を検索(抽出?)しアクティブになっているシートの特定の列に貼り付ける作業を自動で行わせたいと思っております。複数ある行の中から必要な行だけを抽出して、貼り付けるのでフォーマットを整えると思っていただければ結構です。具体的には、
[Sheet1]のデータ↓( | ←は罫線と思ってください。列の順番は毎回A→Zの順番とは限りませんが、記載内容は同じです。)
A | B | C | D | E … | Z
1 | 2 | 3 | 4 | 5 … |26
a | b | c | d | e … | z
1a| 2b| 3c| 4d| 5e… |26z
これらのデータから、特定の必要な列を選んで[Sheet2]に貼り付けを自動で行わせたいのです↓。
[Sheet2]B,G,A,W,O,Iのデータのみ必要な場合
B | G | A | W | O | I
2 | 7 | 1 | 23| 15| 9
b | g | a | w | o | i
2b| 7g| 1a|23w|15o| 9i

行数は最大で500行を超えます。HLOOKUPを各セルに書き込んで置けばよいのですが、ドッラグでは式が正しく書き込めなくて。。。
"=HLOOKUP(A1,Sheet1!A:Z,2,0)"←"A1"はA2,A3,A4となるのですが"2"がずっと2のままなので。

[Sheet1]の特定の行のコピー&ペーストなのですが、[Sheet2]の貼り付け先が1行目からではないので、何かしらの工夫が必要だと思うのですが。。。
たとえば
Columns("B:B").Select
Selection.Copy
Sheets("Sheet2").Select
Cells(2, 1).Paste
こう言う事って出来ませんよね？

私の意は伝わりましたでしょうか？なにとぞよろしくお願いいたします。

回答No.3

fumufumu_2006 · ベストアンサー

こんなのではどうでしょうか？

Sub sample()
'初期設定（コピー元とコピー先のシート、コピーする列を設定）
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim copyColumns As String
Set srcSheet = Sheets("Sheet1")
Set dstSheet = Sheets("Sheet2")
copyColumns = "B,G,A,W,O,I"
'
Dim srcRowTop As Long
Dim srcRowBottom As Long
Dim dstRowTop As Long
Dim dstColumnLeft As Integer
Dim cols() As String
Dim i As Integer
'コピー元の最初と最後の行を取得（有効なデータ行は、A列には必ずデータがあるとします）
srcRowTop = 1
srcRowBottom = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row 'A列の最後のデータの行
If (srcRowBottom = 1) And (srcSheet.Cells(1, 1) = "") Then '最後の行が1行目で、実は1行目にデータが無い場合
Exit Sub 'コピー元データなし
End If
'コピー先の最初の行を設定
dstRowTop = 10 'C10の10
dstColumnLeft = 3 'C10のC(=3)
'コピーする列名を配列へ取得
cols = Split(copyColumns, ",")
'コピー開始
For i = 0 To UBound(cols)
srcSheet.Range(cols(i) & srcRowTop & ":" & cols(i) & srcRowBottom).Copy Destination:=dstSheet.Cells(dstRowTop, i + dstColumnLeft)
Next
End Sub

ちなみに、コピー先が変わったら
'コピー先の最初の行を設定
dstRowTop = 10 'C10の10
dstColumnLeft = 3 'C10のC(=3)
の部分を変更してください。

お礼

出来ました！C10から張り付いてくれました。
A,B,C…を貼り付ける部分のセルの色が白になってしまうので(コピー先はグレー、元は白)、「srcRowTop = 1」の1を2に変えてみたら1行目を含めずその下の部分をコピーして貼り付けてくれました。親切なDescriptionのおかげです。本当にありがとうございました。
また機会がございましたら、よろしくお願い申し上げます。

回答No.4

Wendy02

こんばんは。

>[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A2"よりPasteが始まります。

私の場合は、*　を書き換えればよいはずです。

なお、私の書いていたものは、
>Row1(1行目)には全てデータが入っております。
ということではなく、A列に入っているかどうか、ということです。

　i = 3 '初期値　　*
　　For Each c In ColLists
　　　　''補正する場合　j = Cells(1, c).Column - rng.Cells(1, 1).Column + 1
　　　　''rng.Columns(j).Copy に変える
　　　　rng.Columns(c).Copy Worksheets("Sheet2").Cells(10, i)　'*

　　　　i = i + 1
　　Next c

それと、大勢には影響がないのですが、ルールとして忘れてました。

　　Next c
　　Set rng = Nothing　　'←は、書き加えてください。*
End Sub

お礼

Wendy02さん、
こんばんは。出来ましたよ！本当にどうもありがとうございました。
とってもシンプルで処理が早いです。どうすれば貴殿のようになれるのでしょう。。。自己紹介を読ませていただきましたが、どうやら趣味のようで。。。地道に勉強して行こうと思っております。また機会がございましたら、よろしくお願い申し上げます。

回答No.2

Wendy02

こんにちは。

あまり、難しく考える必要はないと思います。

ただ、注意としては、基本的な考え方としては、範囲(rng)に対する列の列数で、厳密にいうと、A,B,Cという列数というワークシートの列ではありませんが、それさえ、気をつければ、以下のような簡単なコードで済みます。

B列からデータが始まれば、B列が、1列目, C列が、2列目になります。
つまり、Sheet1 のA列からデータがないと、補正しなくてはならない、ということになります。
言い換えると、論理的な列数で、物理的な列名とは違います。

例：データがA列から始まらないばあは、補正します。
　列数(j) = Cells(1, c).Column - rng.Cells(1, 1).Column + 1

'------------------------------------------

Sub Test1()
　　Dim ColLists As Variant
　　Dim c As Variant
　　Dim i As Integer
　　'Dim j As Integer A列からデータばない時、補正が必要
　　Dim rng As Range
　　Const COLLIST As String = "B,G,A,W,O,I"
　　ColLists = Split(COLLIST, ",")
　　'データ範囲
　　Set rng = Worksheets("Sheet1").Range("A1").CurrentRegion
　　i = 1 '初期値
　　For Each c In ColLists
　　　　''補正する場合　j = Cells(1, c).Column - rng.Cells(1, 1).Column + 1
　　　　''rng.Columns(j).Copy に変える
　　　　rng.Columns(c).Copy Worksheets("Sheet2").Cells(2, i)
　　　　i = i + 1
　　Next c
End Sub

お礼

Wendy02さん
早速のご指導ありがとうございます。前回お書きいたしましたとおり、私は全くの初心者でございまして、双方とも試させていただきましたが、もう少しの微調整が出来ずにおります。[Sheet1]の"A"はA1にありB1>C1…Z1と続きます。Row1(1行目)には全てデータが入っております。コピー先の
[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A2"よりPasteが始まります。
どのように書き換えればよろしいのでしょうか？勝手言って申し訳ございませんが、なにとぞよろしくお願いいたします。

回答No.1

fumufumu_2006

こんなのではどうでしょうか？

Sub sample()
'初期設定（コピー元とコピー先のシート、コピーする列を設定）
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
Dim copyColumns As String
Set srcSheet = Sheets("Sheet1")
Set dstSheet = Sheets("Sheet2")
copyColumns = "B,G,A,W,O,I"
'
Dim srcRowTop As Long
Dim srcRowBottom As Long
Dim dstRowTop As Long
Dim cols() As String
Dim i As Integer
'コピー元の最初と最後の行を取得（有効なデータ行は、A列には必ずデータがあるとします）
srcRowTop = 1
srcRowBottom = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row 'A列の最後のデータの行
If (srcRowBottom = 1) And (srcSheet.Cells(1, 1) = "") Then '最後の行が1行目で、実は1行目にデータが無い場合
Exit Sub 'コピー元データなし
End If
'コピー先の最初の行を取得（有効なデータ行は、A列には必ずデータがあるとします）
dstRowTop = dstSheet.Cells(dstSheet.Rows.Count, 1).End(xlUp).Row + 1 'A列の最後のデータの行+1
If (dstRowTop = 2) And (dstSheet.Cells(1, 1) = "") Then '最初の行が2行目で、実は1行目にデータが無い場合
dstRowTop = 1 'コピー先データなし（コピー先は先頭行から）
End If
'コピーする列名を配列へ取得
cols = Split(copyColumns, ",")
'コピー開始
For i = 0 To UBound(cols)
srcSheet.Range(cols(i) & srcRowTop & ":" & cols(i) & srcRowBottom).Copy Destination:=dstSheet.Cells(dstRowTop, i + 1)
Next
End Sub

お礼

fumufumu_2006さん,
早速のご指導ありがとうございます。前回お書きいたしましたとおり、私は全くの初心者でございまして、双方とも試させていただきましたが、もう少しの微調整が出来ずにおります。[Sheet1]の"A"はA1にありB1>C1…Z1と続きます。Row1(1行目)には全てデータが入っております。コピー先の
[Sheet2]のBは"C10(=10,3)"のセルから、G="D10", A="E10"…I="H10=(10,8)"と続きます。貴殿の記述ですと"A1"からpasteが始まります。
どのように書き換えればよろしいのでしょうか？勝手言って申し訳ございませんが、なにとぞよろしくお願いいたします。