エクセルＶＢＡでのデータ抽出についての質問です。

質問

エクセルＶＢＡでのデータ抽出についての質問です。

下記のような２つのシートがあります。

（シート１）
ＡＡ　ＢＢ　ＣＣ　ＤＤ　ＥＥ　ＦＦ　ＧＧ　ＨＨ　←タイトル（複数固定）
ああ　いい　うう　ええ　おお　かか　きき　けけ　←値
ささ　しし　すす　せせ　そそ　たた　なな　はは　←値
まま　みみ　むむ　めめ　もも　らら　りり　るる　←値

（シート２）
ＡＡ　ＦＦ　ＨＨ　・・・　←タイトル（数は変更あり）

シート１にタイトルの付いたデータが１００列ほどありまして、
シート２に抽出したい列だけのタイトルを並べたとします。

このシート２のタイトルに入れたデータのみをシート１から列ごと
抽出してきたい場合、マクロで可能でしょうか。
本来はアクセスなどを使ってデータベースでクエリ抽出してくるものだと思いますが、
マクロでなんとかしたいと思っております。

回答No.5

debunyanko-28 · ベストアンサー

debunyanko-28です。

自由に変更してもらって構いませんよ。

ちなみに私なら以下のようにします。

Sub test4()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim c As Range
　　Dim i As Variant

　　Set Ws1 = Worksheets("item_list.tsv")
　　Set Ws2 = Worksheets("商品")
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(1, Columns.Count).End(xlToLeft))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(1, Columns.Count).End(xlToLeft))

　　For Each c In myRange2
　　　　i = Application.Match(c.Value, myRange1, 0)
　　　　If Not IsError(i) Then
　　　　　　Ws1.Range(Ws1.Cells(1, i), Ws1.Cells(Rows.Count, i).End(xlUp)).Copy _
　　　　　　　　Destination:=c
　　　　End If
　　Next c

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

お礼

なるほど。1行目からにすればタイトルなので重複しないですね。
ありがとうございました。

回答No.4

debunyanko-28

ごめんなさい。

前回は間違ってます。
訂正版です。

Sub test2()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim c As Range
　　Dim i As Variant

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(1, Columns.Count).End(xlToLeft))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(1, Columns.Count).End(xlToLeft))

　　For Each c In myRange2
　　　　i = Application.Match(c.Value, myRange1, 0)
　　　　If Not IsError(i) Then
　　　　　　Ws1.Range(Ws1.Cells(2, i), Ws1.Cells(Rows.Count, i).End(xlUp)).Copy _
　　　　　　　　Destination:=c.Offset(1)
　　　　End If
　　Next c

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

お礼

ありがとうございます。
１点だけ、説明に書いてませんでしたが、シート１にデータがないパターンがあり、
その場合タイトル列まで、コピーされてしまうので下記のように追加させて頂きました。

Sub test3()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim myRange1 As Range
Dim myRange2 As Range
Dim c As Range
Dim i As Variant
Dim r As Long

Set Ws1 = Worksheets("item_list.tsv")
Set Ws2 = Worksheets("商品")
Set myRange1 = Ws1.Range("A1", Ws1.Cells(1, Columns.Count).End(xlToLeft))
Set myRange2 = Ws2.Range("A1", Ws2.Cells(1, Columns.Count).End(xlToLeft))

For Each c In myRange2
i = Application.Match(c.Value, myRange1, 0)

If Not IsError(i) Then

r = Ws1.Cells(Rows.Count, i).End(xlUp).row
If r = 1 Then r = 2

Ws1.Range(Ws1.Cells(2, i), Ws1.Cells(r, i)).Copy _
Destination:=c.Offset(1)
End If
Next c

Set Ws1 = Nothing
Set Ws2 = Nothing
Set myRange1 = Nothing
Set myRange2 = Nothing
End Sub

回答No.3

debunyanko-28

一つの例ですが・・・

タイトルの行は一列目の前提です。

Sub test()
　　Dim Ws1 As Worksheet
　　Dim Ws2 As Worksheet
　　Dim myRange1 As Range
　　Dim myRange2 As Range
　　Dim c As Range
　　Dim i As Long

　　Set Ws1 = Worksheets("Sheet1")
　　Set Ws2 = Worksheets("Sheet2")　　
　　Set myRange1 = Ws1.Range("A1", Ws1.Cells(1, Columns.Count).End(xlToLeft))
　　Set myRange2 = Ws2.Range("A1", Ws2.Cells(1, Columns.Count).End(xlToLeft))

　　For Each c In myRange2
　　　　If IsError(myAns) = False Then
　　　　　　i = Application.Match(c.Value, myRange1, 0)
　　　　　　With Ws1
　　　　　　　　.Range(.Cells(2, i), .Cells(Rows.Count, i).End(xlUp)).Copy _
　　　　　　　　　　Destination:=c.Offset(1)
　　　　　　End With
　　　　End If
　　Next c

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
　　Set myRange1 = Nothing
　　Set myRange2 = Nothing
End Sub

お礼

テストさせて頂いたところうまく動作しました！
あとはＷｓのシート名を変更するなどしてアレンジさせていただきます！
本当にありがとうございました！！
それにしても無駄がなくて綺麗なソースですね。動作も早いです。

回答No.2

kmetu

たとえばシート2のA2に

=HLOOKUP(A1,Sheet1!A1:H4,2,FALSE)

とかでいけると思いますが。マクロがいいのでしょうか。

補足

回答ありがとうございます。
ＨＬＯＯＫＵＰも考えたのですが数が多いのと
同じ動作を毎回繰り返す必要があるので、
マクロがいいのであります。

回答No.1

rukuku

こんばんは

makilon03さんの腕次第ですが、可能です。
手作業でやるとしたら、
１．結果出力用にシート３を用意する
２．シート２のリストを上から一つずつチェックして、シート１に同名のタイトルがあればシート３にコピー
３．以下、シート２のリストが終わるまで繰り返し。
です。
→この手順をExcel VBAで組むことが出来ます。

＞本来はアクセスなどを使ってデータベースでクエリ抽出してくるものだと思いますが、
元データがデーターベース向きではなさそうなので、アクセス使うと余計に難しくなりそうです。Excel VBAの方が柔軟な対応が出来ます。

Find
End(xlup)
For
がキーワードです。