'┌──────────────────────────
'│ エクセルからエクセルへの転記
'│
'│ [説明]
'│ 1)ひな形となるエクセルでこの処理を実行してください。
'│   ボタンを作る場合は、ひな形シート内に作ってください。
'│
'│ 2)出力ファイルは".xlsx"形式です。
'│
'│ 3)◆設定1~2を書き変えて使います。
'│
'│
'│ [更新履歴]
'│ 2020.07.31 作成
'│
'└──────────────────────────
Sub Tenki()
'[宣言]
Dim FileName1, FileName2, SheetName1, SheetName2 As String
Dim ws0, ws1, ws2 As Worksheet
Dim i As Long

'-----------------------
'◆設定1
FileName1 = "一覧.xlsx" '一覧のファイル名
SheetName1 = "リスト" '一覧のシート名
SheetName2 = "ひな形" 'ひな形のシート名
'-----------------------

'ボタンを消す
If Workbooks(ThisWorkbook.Name).Worksheets(SheetName2).Shapes.Count > 0 Then
Dim shp As Shape
For Each shp In Workbooks(ThisWorkbook.Name).Worksheets(SheetName2).Shapes
shp.Delete
Next shp
End If

FileName2 = Year(Now()) & Month(Now()) & Day(Now()) & Right("0" & Hour(Now()), 2) & Right("0" & Minute(Now()), 2) & Right("0" & Second(Now()), 2) & "作成.xlsx"
Application.DisplayAlerts = False
Workbooks(ThisWorkbook.Name).SaveAs Filename:=ThisWorkbook.Path & "\" & FileName2, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Workbooks.Open ThisWorkbook.Path & "\" & FileName1

Set ws1 = Workbooks(FileName1).Worksheets(SheetName1) '◆設定1で指定したシート名を使いたい場合
Set ws0 = Workbooks(FileName2).Worksheets(SheetName2)



'[一覧読込]
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row '一覧シートの1列目を2行目から最終行まで(昇順)

'[シートコピー]
ws0.Copy after:=Workbooks(FileName2).Worksheets(Worksheets.Count) 'ブックの末尾にコピーする
Set ws2 = Workbooks(FileName2).Worksheets(Worksheets.Count)

'---------------------------------------------
'◆設定2 .Cells(行, 列)を指定
ws2.Name = ws1.Cells(i, 2).Value 'シートの名前
ws2.Cells(3, 2).Value = ws1.Cells(i, 1).Value
ws2.Cells(7, 2).Value = ws1.Cells(i, 2).Value
ws2.Cells(5, 2).Value = ws1.Cells(i, 3).Value
ws2.Cells(5, 3).Value = ws1.Cells(i, 4).Value
ws2.Cells(5, 4).Value = ws1.Cells(i, 5).Value
ws2.Cells(5, 5).Value = ws1.Cells(i, 6).Value
'---------------------------------------------

Set ws2 = Nothing

Next i

'[ひな形シート削除]
'※ひな形シートのオブジェクトとして記述した場合はエラーになります。
Application.DisplayAlerts = False
ws0.Delete
Application.DisplayAlerts = True

'[保存]
Workbooks(FileName2).Save 'エクセルを保存
Workbooks(FileName1).Close 'エクセルを閉じる

MsgBox "完了しました。"
End Sub

'┌──────────────────────────
'│ エクセルからエクセルへの転記
'│ (一覧を逆からたどる版)
'│
'│ [説明]
'│ 1)ひな形となるエクセルでこの処理を実行してください。
'│   ボタンを作る場合は、ひな形シート内に作ってください。
'│
'│ 2)出力ファイルは".xlsx"形式です。
'│
'│ 3)◆設定1~2を書き変えて使います。
'│
'│
'│ [更新履歴]
'│ 2020.08.04 作成
'│
'└──────────────────────────
Sub Tenkinoko()
'[宣言]
Dim FileName1, FileName2, SheetName1, SheetName2 As String
Dim ws0, ws1, ws2 As Worksheet
Dim i As Long

'-----------------------
'◆設定1
FileName1 = "一覧.xlsx" '一覧のファイル名
SheetName1 = "リスト" '一覧のシート名
SheetName2 = "ひな形" 'ひな形のシート名
'-----------------------

'ボタンを消す
If Workbooks(ThisWorkbook.Name).Worksheets(SheetName2).Shapes.Count > 0 Then
Dim shp As Shape
For Each shp In Workbooks(ThisWorkbook.Name).Worksheets(SheetName2).Shapes
shp.Delete
Next shp
End If

FileName2 = Year(Now()) & Month(Now()) & Day(Now()) & Right("0" & Hour(Now()), 2) & Right("0" & Minute(Now()), 2) & Right("0" & Second(Now()), 2) & "作成.xlsx"
Application.DisplayAlerts = False
Workbooks(ThisWorkbook.Name).SaveAs Filename:=ThisWorkbook.Path & "\" & FileName2, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Workbooks.Open ThisWorkbook.Path & "\" & FileName1

Set ws1 = Workbooks(FileName1).Worksheets(SheetName1) '◆設定1で指定したシート名を使用
Set ws0 = Workbooks(FileName2).Worksheets(SheetName2)

'[一覧読込]
For i = ws1.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 '一覧シートの1列目を最終行から2行目まで繰り返し(降順)

'[シートコピー]
ws0.Copy before:=Workbooks(FileName2).Worksheets(1) 'ブックの先頭にコピーする
Set ws2 = Workbooks(FileName2).Worksheets(1)

'---------------------------------------------
'◆設定2 .Cells(行, 列)を指定
ws2.Name = ws1.Cells(i, 2).Value 'シートの名前
ws2.Cells(3, 2).Value = ws1.Cells(i, 1).Value
ws2.Cells(7, 2).Value = ws1.Cells(i, 2).Value
ws2.Cells(5, 2).Value = ws1.Cells(i, 3).Value
ws2.Cells(5, 3).Value = ws1.Cells(i, 4).Value
ws2.Cells(5, 4).Value = ws1.Cells(i, 5).Value
ws2.Cells(5, 5).Value = ws1.Cells(i, 6).Value
'---------------------------------------------

Set ws2 = Nothing

Next i

'[ひな形シート削除]
'※ひな形シートのオブジェクトとして記述した場合はエラーになります。
Application.DisplayAlerts = False
ws0.Delete
Application.DisplayAlerts = True

'[保存]
Workbooks(FileName2).Save 'エクセルを保存
Workbooks(FileName1).Close 'エクセルを閉じる

MsgBox "完了しました。"
End Sub