【VBA】シート名と見出しが一致する列をコピーする

いつも親切に教えてくださりありがとうございます。
今回悩んでいるのは下記内容です。

・シート「①」「①の元データ」「②」「②の元データ」……のように、①～⑮までの
　元データとそれを貼り付けるためのシートが存在する
・貼り付け元のシートを「～の元データ」、貼り付け先のシートをそれに対応する数字とする
・①②③……のシートへ、①の元データ・②の元データ・③の元データ……のシートから、
　①②③……のシートに同じ名前の見出しがある列のみコピーしたい

このような内容です。もしわかる方がいらっしゃればお知恵をお借りしたいです。
よろしくお願いいたします。

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/03/11 19:32

以下のマクロを標準モジュールに登録してください。

Option Explicit

Public Sub シート間転記()
Dim sws As Worksheet
Dim tws As Worksheet
Dim sh_array As Variant
Dim i As Long
sh_array = Array("①", "②", "③", "④", "⑤", "⑥", "⑦", "⑧", "⑨", "⑩", "⑪", "⑫", "⑬", "⑭", "15")
For i = 0 To UBound(sh_array)
Set sws = Worksheets(sh_array(i) & "の元データ")
Set tws = Worksheets(sh_array(i))
Call sheet_copy(sws, tws)
Next
End Sub

Private Sub sheet_copy(sws As Worksheet, tws As Worksheet)
Dim wcol As Long
Dim dicT As Object
Dim maxcol1 As Long
Dim maxcol2 As Long
Dim col1 As Long
Dim col2 As Long
Dim key As String
Set dicT = CreateObject("Scripting.Dictionary")
maxcol1 = sws.Cells(1, Columns.Count).End(xlToLeft).Column
maxcol2 = tws.Cells(1, Columns.Count).End(xlToLeft).Column
tws.Rows("2:" & Rows.Count).ClearContents
For col2 = 1 To maxcol2
key = tws.Cells(1, col2).Value
If key <> "" Then
dicT(key) = col2
End If
Next
For col1 = 1 To maxcol1
key = sws.Cells(1, col1).Value
If key <> "" Then
If dicT.exists(key) = True Then
col2 = dicT(key)
sws.Columns(col1).Copy Destination:=tws.Columns(col2)
End If
End If
Next
End Sub

この回答へのお礼

ありがとうございます！
こちらでやってみます！！

お礼日時：2024/03/22 11:08

No.1 回答者： fujillin 回答日時： 2024/03/11 14:30

こんにちは

どこがわからないのかもわかりませんけれど・・・

基本的には、一つのシートへの転記処理を作成して、それをループして、必要なだけ繰り返すようにすれば宜しそうに思われます。

シートのセットは
　・文字の連結
　・指定シートの存在確認
が出来れば良いので、できているものと仮定して・・

順に1列ずつ処理をしてゆくとして、
タイトルと合致する列の検索がわからないということでしょうか？
簡単にやるなら、1行目から一致するものを探せば良いだけなので、
　元シート.Rows(1).Find(検索したいタイトル）
などで、探すことが可能です。
https://learn.microsoft.com/ja-jp/office/vba/api …
あるいは、1行目をループして、値が一致するセルを探しても宜しいかと。
　
あとは、対象列をコピペすればよいだけなので、
　参照元列.Copy 転記先列
とすれば列のコピーができます。
値だけを転記したければ、
　転記先列.Value = 参照元列.Value
で「値の転記」が可能です。

この回答へのお礼

ありがとうございます！

お礼日時：2024/03/22 11:08