ExcelVBAの転記（1つのひな形へ複数シート）

質問

お世話になります。ExcelVBAを少し学んだ程度の者です。

1つのExcelファイルに複数存在する個別のシートから、1つのひな形シートへ転記する方法に頭を悩ませております。イメージとしては名簿管理のようなものとご理解してください。
複数存在するシート（約200シート）には、項目名に対するデータ（例えば、名前や住所などが定められたセルに入力されています）が揃っておりますが、書式の変更によりひな形のシートへ転記する必要があります。

200ほどのシートには、M10セルには名前が、B15セルには住所、C16セルには電話番号が……という具合に入力されています。これらのデータをひな形シートでは、N5セルに名前、C13セルに住所、D14セルには電話番号などを転記する必要があります（セル番地は適当です）。

ひな形シートは1枚で、マクロを実行する際にひな形シートをコピーして（Xとします）、200ほどの個別のシート（A、B、C……）を転記しようと思っております。A、B、C……に入力された複数の値は項目別にCells(i,j).Valueを、XへCells(x,y).Valueへ転記すれば良いと考えておりましたが、上手くいきません。ひな形をコピーしたXのシートへ上手く転記ができず、Aを転記したシートばかりが量産され、B、C以降のシートへ制御が移っていないようです。恐らく、Workwsheetオブジェクトのカウンタ変数に問題があると思われます。

VBAのコードとしては下記のように記述しております。
Sub SheetCopy()
Application.ScreenUpdating = False
Dim cnt As Long 'シート数カウント変数
Dim i As Long 'シート用のカウンタ変数
Dim wb As Workbook 'コピー元
Dim ws1 As Worksheet 'コピー元
Dim ws2 As Worksheet 'コピー先
'1がコピー元で2がコピー先
cnt = Worksheets.Count 'シート数をカウント
i = 2
Set wb = Workbooks("転記用.xlsm")
Set ws1 = wb.Worksheets(i)
Set ws2 = wb.Worksheets("ひな形")

For i = 1 To cnt
ws2.Copy after:=Worksheets(i)
Set ws2 = wb.Worksheets(i)
ws2.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前
ws2.Cells(3, 2).Value = ws1.Cells(6, 10).Value '住所
以下、同様の転記処理を記述しています。
Next i
End Sub

上記のコードを、パッと見たところ、コピーはしているものの、転記先がコピー元になっているのも原因だと思います（コピー先へ転記する方法が現時点でわかりかねます……ここがネックだと考えております）。

ご知見のある方々から、アドバイスをいただけると幸いです。

どうぞ、よろしくお願い申し上げます。

回答No.3

kkkkkm · ベストアンサー

ws2.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前

ws1は
i = 2
Set ws1 = wb.Worksheets(i)
これだけしかセットしていませんから、いくらループしても転記元はWorksheets(2)のままです。
ws2は
ループの中で
Set ws2 = wb.Worksheets(i)
されてますから、iの値で増えていきますから転記先は変更されています。
ですので、Aを転記したシートばかりが量産されているのだと思います。

同じブックに200のシートを追加したら400になって管理が面倒そうなので、新しく別ブックにデータを転記する方法はどうでしょうか。
元のブックの左端をひな形にしておいてください。
ひな形シートを転記先にコピーしながら転記元の左から2番目のシートから順に転記します。
転記時にシート名を「ひな形」から元のシート名へ変更しています。
最後にひな形だけのシートもコピーします。
ひな形の場所は転記元の転記用.xlsmの左端にあるものとしています。
転記するデータは転記用.xlsmにあるものとします。

Sub SheetCopy()
Application.ScreenUpdating = False
Dim cnt As Long 'シート数カウント変数
Dim i As Long 'シート用のカウンタ変数
Dim wb As Workbook 'コピー元
Dim wb2 As Workbook
Dim ws1 As Worksheet 'コピー元 転記用.xlsm
Dim ws2 As Worksheet 'コピー元 ひな形
Dim ws3 As Worksheet 'コピー先

i = 2
Set wb = Workbooks("転記用.xlsm")
Set ws2 = wb.Worksheets("ひな形")
Set ws1 = wb.Worksheets(i)

cnt = wb.Worksheets.Count 'シート数をカウント

ws2.Copy 'これだけでひな形シートだけの新しいブックができます
Set wb2 = ActiveWorkbook
wb2.SaveAs ThisWorkbook.Path & "\転記先.xlsx" 'ブックを保存しています
Set ws3 = wb2.Worksheets(1)
ws3.Name = ws1.Name '元のシート名をコピー先に適用

For i = 2 To cnt '左端がひな形なので2から
Set ws1 = wb.Worksheets(i)
Set ws3 = wb2.Worksheets(i - 1)
ws3.Name = ws1.Name
ws3.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前
ws3.Cells(3, 2).Value = ws1.Cells(6, 10).Value '住所
' 以下､同様の転記処理を記述しています｡
ws2.Copy after:=wb2.Worksheets(i - 1)
Set ws1 = Nothing
Set ws3 = Nothing
Next i
Set ws2 = Nothing
Set wb2 = Nothing
Set wb = Nothing
Application.ScreenUpdating = True

End Sub

お礼

ご丁寧なご回答をいただきまして、ありがとうございました。

おっしゃる通り、意図しない挙動をしておりましたが、暖かいご指導のおかげで理解いたしました。また、実現したかった動作となり、感謝しております。

繰り返しとはなりますが、本当にありがとうございました。

回答No.2

f272

やりたいことがよくわからん。

> コピーした「ひな形」シートへ対して、1枚のシートを転記。

「ひな形」シートはどこからコピーするのか？
その後に「ひな形」シートの1枚目のシートの一部の内容を転記する、ということでよいか？

> その後に、新たに「ひな形」シートをコピーして当該シートへ2枚目のシート内容を転記。

その後に「新たに「ひな形」シートをコピー」というのはどういうことか？別の場所にコピーするなら、それはどこか？同じブックの中ならさっきの「ひな形」シートとの関係はどうなるのか？

補足

貴殿からのご回答は結構でございます。

回答No.1

f272

こんな感じ？
Sub SheetCopy()
Dim cnt As Long 'シート数カウント変数
Dim i As Long 'シート用のカウンタ変数
Dim wb As Workbook 'コピー元
Dim ws1 As Worksheet 'コピー元
Dim ws2 As Worksheet 'コピー先
Set wb = Workbooks("転記用.xlsm")
cnt = wb.worksheets.Count 'シート数をカウント
Set ws2 = wb.Worksheets("ひな形")
For i = 1 To cnt
Set ws1 = wb.Worksheets(i)
if ws1.name <> "ひな形" then
ws2.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前
ws2.Cells(3, 2).Value = ws1.Cells(6, 10).Value '住所
end if
Next i
End Sub

補足

ご回答ありがとうございます。早速試してみました。

結果はNGでした。ひな形シートへデータが転記されたのみとなります。私の説明が悪かったことが起因しております。

実現したいことは、コピーした「ひな形」シートへ対して、1枚のシートを転記。その後に、新たに「ひな形」シートをコピーして当該シートへ2枚目のシート内容を転記。これを、約200シートについて行いたいという内容となります（1ファイルに、シート数が約200増えることになるかと拝察いたします）。

コピーした「ひな形」シートに対して機械的に名前を付けることができれば、シートオブジェクトに対して転記の命令文を記述できるかと思うのですが、その方法がわからず現在に至っております。コピーされた「ひな形」シートを指定する方法がわかっておりません。

どうぞ、お知恵の拝借をお願い申し上げます。