VBA データシートから指定した列を新規シートにコピーしたい

ｖｂａ初心者です。
色々なものを見て自分なりにやってはいるのですが、どうしても思い通りにいきません。
知識不足で申し訳ありませんが、お助けいただけると嬉しいです。
実際のdataはもっと多くのデータがあり、作業したいブック数も多いためマクロで作業したいと思っています。

dataシートにデータがあります。
1行目が指定したい項目になっています。
データの行数、列数はその時によって増減します。（A列の日付が増えたり、1行目の項目も増減します）

リストを作成して、
リストのC列以降にある項目を列ごと新規シートにコピー、その新規シートの名前はリストB列の名前にしたいです。
下の画像は分かりやすく列に色を付けていますが、実際のデータは色、罫線はなく書式は気にせずです。

説明がわかりずらかったら申し訳ありません。
よろしくお願いします。

質問者からの補足コメント

• 1つのブックの方法がわかれば残りについては応用できる、ということで大丈夫です。
  リストの座標は画像の通りになります。
  (でもこの形にこだわっている訳ではないので、もし他に良い方法があればご教授頂けると嬉しいです。)
  VBAは元々あるものを改良するのは出来る、程度の初心者ですm(_ _)m

  No.1の回答に寄せられた補足コメントです。 補足日時：2019/08/08 19:20

No.3 回答者： めぐみん_ 回答日時： 2019/08/09 06:20

No.1です。

別回答が出たようですのでそちらにお任せします。
ダミーデータ作成に手こずってますし、dataシートの項目名が増減するならリストの項目名も増減しそうです。
面倒なのでそれを一発で引き出そうとしましたけど、Ａｃｃｅｓｓとかの経験がないとしたらややこしく感じるでしょう。
純粋にＥｘｃｅｌの機能のみの方がわかりやすいかなと思いましたので。

この回答へのお礼

ありがとうございましたm(__)m

お礼日時：2019/08/09 15:35

No.2 ベストアンサー 回答者： tom04 回答日時： 2019/08/08 21:02

こんにちは！

「リスト」シートはお示しの画像通りの配置だとします。
一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, j As Long, k As Long, lastRow As Long, cnt As Long
　Dim sN As String, wS1 As Worksheet, wS2 As Worksheet
　Dim c As Range, myFlg As Boolean

　　Application.ScreenUpdating = False
　　　Set wS1 = Worksheets("data")
　　　lastRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
　　　　With Worksheets("リスト")
　　　　　For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　sN = .Cells(i, "B")
　　　　　　For k = 3 To Worksheets.Count
　　　　　　　If Worksheets(k).Name = sN Then
　　　　　　　　myFlg = True
　　　　　　　　Exit For
　　　　　　　End If
　　　　　　Next k
　　　　　　　If myFlg = False Then
　　　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　　　　　　　　ActiveSheet.Name = sN
　　　　　　　End If
　　　　　　　　Set wS2 = Worksheets(sN)
　　　　　　　　　wS2.Move after:=Worksheets(i)
　　　　　　　　　wS2.Cells.ClearContents
　　　　　　　　For j = 3 To .Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　　　　Set c = wS1.Rows(1).Find(what:=.Cells(i, j), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　　　If Not c Is Nothing Then '//←念のため//
　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　Range(wS1.Cells(1, c.Column), wS1.Cells(lastRow, c.Column)).Copy wS2.Cells(1, cnt)
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　　　　cnt = 0
　　　　　　　　　myFlg = False
　　　　　Next i
　　　　End With
　　Application.ScreenUpdating = True
　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

うまくできました！ありがとうございますm(__)m

お礼日時：2019/08/09 15:34

No.1 回答者： めぐみん_ 回答日時： 2019/08/08 18:39

気になる点としては、

＞作業したいブック数も多いため

質問の『１つのブックの方法がわかれば残りについてはそちらで応用できる』と言う事なのかどうか？（複数のブックに跨ってデータ収集をするのかしないのか？）
シート名：リストの表の座標位置は画像の通りなのか？
初心者って事はVBAの経験自体はある（程度は不明ですが）としてコードを提示されても理解が出来ると考えて構わないのか？

辺りですかね？