Option Explicit
Public Sub データ転記()
    Const folder1 As String = "D:\goo\data"     '転記元ブック格納フォルダ
    Dim wpath1 As String        '転記元ブックパス
    Dim wb1 As Workbook         '転記元ブック
    Dim ws1 As Worksheet        '転記元シート
    Dim ws2 As Worksheet        '転記先シート
    '転記元の行、列定義
    Dim FrCol1 As Variant       '転記元列（6列用）
    Dim FrCol2 As Variant       '転記元列（3列用）
    Dim FrRow1 As Variant       '転記元行(FrCol1用)
    Dim FrRow2 As Variant       '転記元行(FrCol2用)
    FrCol1 = Array("H", "Q", "AA", "AJ", "AT", "BC")
    FrCol2 = Array("S", "AL", "BE")
    FrRow1 = Array(10, 11, 17, 18)
    FrRow2 = Array(13, 15, 20, 22)
    '転記先の行、列定義
    Dim ToCol1 As Variant       '転記先列（6列用）
    Dim ToCol2 As Variant       '転記先列（3列用）
    Dim ToRow1 As Variant       '転記先行(ToCol1用)
    Dim ToRow2 As Variant       '転記先行(ToCol2用)
    ToCol1 = Array("H", "S", "AD", "AO", "AZ", "BK")
    ToCol2 = Array("U", "AQ", "BM")
    ToRow1 = Array(12, 13, 24, 25)
    ToRow2 = Array(15, 17, 27, 29)
 
    Dim maxp As Long            '最大ページ数
    Dim pno As Long             'ページ番号
    Dim row1 As Long            '転記元行番号
    Dim row2 As Long            '転記先行番号
    Dim col1 As String          '転記元列名
    Dim col2 As String          '転記先列名
    Dim i As Long
    Dim j As Long
 
    Application.ScreenUpdating = False
    wpath1 = folder1 & "\" & "転記元.xls"
    Set wb1 = Workbooks.Open(wpath1)
    Set ws1 = wb1.Worksheets("原本")
    Set ws2 = ThisWorkbook.Worksheets("データ転記")
 
    maxp = ws1.PageSetup.Pages.Count
    If maxp > 100 Then
        MsgBox ("転記元ページ数が100を超えてます")
    End If
 
    '転記先のシートを空の１ページ分をコピーして、最大ページ数分作成する
    For pno = 2 To maxp
        row2 = (pno - 1) * 35 + 1
        Call copy_page(ws2.Range("A1:BR35"), ws2.Range("A" & row2))
    Next
    '転記元から転記先へ１～最大ページ数まで転記する
    For pno = 1 To maxp
        '6列分のデータ転記
        For i = 0 To UBound(FrRow1)
            '転記元、転記先の行番号を算出
            row1 = (pno - 1) * 23 + FrRow1(i)
            row2 = (pno - 1) * 35 + ToRow1(i)
            For j = 0 To UBound(FrCol1)
                '転記元、転記先の列名を算出
                col1 = FrCol1(j)
                col2 = ToCol1(j)
                '転記先へ転記
                ws2.Cells(row2, col2).Value = ws1.Cells(row1, col1).Value
            Next
        Next
        '3列分のデータ転記
        For i = 0 To UBound(FrRow2)
            '転記元、転記先の行番号を算出
            row1 = (pno - 1) * 23 + FrRow2(i)
            row2 = (pno - 1) * 35 + ToRow2(i)
            For j = 0 To UBound(FrCol2)
                '転記元、転記先の列名を算出
                col1 = FrCol2(j)
                col2 = ToCol2(j)
                '転記先へ転記
                ws2.Cells(row2, col2).Value = ws1.Cells(row1, col1).Value
            Next
        Next
    Next
    wb1.Close
    '改ページを入れる
    For pno = 2 To maxp
        row2 = (pno - 1) * 35 + 1
        ws2.Range("BS" & row2).PageBreak = xlPageBreakManual
    Next
    '印刷範囲設定
    ws2.PageSetup.PrintArea = "$A$1:$BR$" & maxp * 35
    Application.ScreenUpdating = True
    MsgBox ("完了")
End Sub
'1ページ分のコピー
Private Sub copy_page(ByVal SourceRange As Range, ByVal destinationRange As Range)
    SourceRange.Copy
    destinationRange.PasteSpecial xlPasteAll
    Dim i As Long
    With SourceRange
        For i = 1 To .Rows.Count
            'コピー元の行の高さを取得してコピー先の行の高さを設定
            destinationRange.Rows(i).RowHeight = .Rows(i).RowHeight
        Next
    End With
End Sub
 
 

T3B0aW9uIEV4cGxpY2l0ClB1YmxpYyBTdWIg44OH44O844K/6Lui6KiYKCkKICAgIENvbnN0IGZvbGRlcjEgQXMgU3RyaW5nID0gIkQ6XGdvb1xkYXRhIiAgICAgJ+i7ouiomOWFg+ODluODg+OCr+agvOe0jeODleOCqeODq+ODgAogICAgRGltIHdwYXRoMSBBcyBTdHJpbmcgICAgICAgICfou6LoqJjlhYPjg5bjg4Pjgq/jg5HjgrkKICAgIERpbSB3YjEgQXMgV29ya2Jvb2sgICAgICAgICAn6Lui6KiY5YWD44OW44OD44KvCiAgICBEaW0gd3MxIEFzIFdvcmtzaGVldCAgICAgICAgJ+i7ouiomOWFg+OCt+ODvOODiAogICAgRGltIHdzMiBBcyBXb3Jrc2hlZXQgICAgICAgICfou6LoqJjlhYjjgrfjg7zjg4gKICAgICfou6LoqJjlhYPjga7ooYzjgIHliJflrprnvqkKICAgIERpbSBGckNvbDEgQXMgVmFyaWFudCAgICAgICAn6Lui6KiY5YWD5YiX77yINuWIl+eUqO+8iQogICAgRGltIEZyQ29sMiBBcyBWYXJpYW50ICAgICAgICfou6LoqJjlhYPliJfvvIgz5YiX55So77yJCiAgICBEaW0gRnJSb3cxIEFzIFZhcmlhbnQgICAgICAgJ+i7ouiomOWFg+ihjChGckNvbDHnlKgpCiAgICBEaW0gRnJSb3cyIEFzIFZhcmlhbnQgICAgICAgJ+i7ouiomOWFg+ihjChGckNvbDLnlKgpCiAgICBGckNvbDEgPSBBcnJheSgiSCIsICJRIiwgIkFBIiwgIkFKIiwgIkFUIiwgIkJDIikKICAgIEZyQ29sMiA9IEFycmF5KCJTIiwgIkFMIiwgIkJFIikKICAgIEZyUm93MSA9IEFycmF5KDEwLCAxMSwgMTcsIDE4KQogICAgRnJSb3cyID0gQXJyYXkoMTMsIDE1LCAyMCwgMjIpCiAgICAn6Lui6KiY5YWI44Gu6KGM44CB5YiX5a6a576pCiAgICBEaW0gVG9Db2wxIEFzIFZhcmlhbnQgICAgICAgJ+i7ouiomOWFiOWIl++8iDbliJfnlKjvvIkKICAgIERpbSBUb0NvbDIgQXMgVmFyaWFudCAgICAgICAn6Lui6KiY5YWI5YiX77yIM+WIl+eUqO+8iQogICAgRGltIFRvUm93MSBBcyBWYXJpYW50ICAgICAgICfou6LoqJjlhYjooYwoVG9Db2wx55SoKQogICAgRGltIFRvUm93MiBBcyBWYXJpYW50ICAgICAgICfou6LoqJjlhYjooYwoVG9Db2wy55SoKQogICAgVG9Db2wxID0gQXJyYXkoIkgiLCAiUyIsICJBRCIsICJBTyIsICJBWiIsICJCSyIpCiAgICBUb0NvbDIgPSBBcnJheSgiVSIsICJBUSIsICJCTSIpCiAgICBUb1JvdzEgPSBBcnJheSgxMiwgMTMsIDI0LCAyNSkKICAgIFRvUm93MiA9IEFycmF5KDE1LCAxNywgMjcsIDI5KQogICAgCiAgICBEaW0gbWF4cCBBcyBMb25nICAgICAgICAgICAgJ+acgOWkp+ODmuODvOOCuOaVsAogICAgRGltIHBubyBBcyBMb25nICAgICAgICAgICAgICfjg5rjg7zjgrjnlarlj7cKICAgIERpbSByb3cxIEFzIExvbmcgICAgICAgICAgICAn6Lui6KiY5YWD6KGM55Wq5Y+3CiAgICBEaW0gcm93MiBBcyBMb25nICAgICAgICAgICAgJ+i7ouiomOWFiOihjOeVquWPtwogICAgRGltIGNvbDEgQXMgU3RyaW5nICAgICAgICAgICfou6LoqJjlhYPliJflkI0KICAgIERpbSBjb2wyIEFzIFN0cmluZyAgICAgICAgICAn6Lui6KiY5YWI5YiX5ZCNCiAgICBEaW0gaSBBcyBMb25nCiAgICBEaW0gaiBBcyBMb25nCiAgICAKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gRmFsc2UKICAgIHdwYXRoMSA9IGZvbGRlcjEgJiAiXCIgJiAi6Lui6KiY5YWDLnhscyIKICAgIFNldCB3YjEgPSBXb3JrYm9va3MuT3Blbih3cGF0aDEpCiAgICBTZXQgd3MxID0gd2IxLldvcmtzaGVldHMoIuWOn+acrCIpCiAgICBTZXQgd3MyID0gVGhpc1dvcmtib29rLldvcmtzaGVldHMoIuODh+ODvOOCv+i7ouiomCIpCiAgICAKICAgIG1heHAgPSB3czEuUGFnZVNldHVwLlBhZ2VzLkNvdW50CiAgICBJZiBtYXhwID4gMTAwIFRoZW4KICAgICAgICBNc2dCb3ggKCLou6LoqJjlhYPjg5rjg7zjgrjmlbDjgYwxMDDjgpLotoXjgYjjgabjgb7jgZkiKQogICAgRW5kIElmCiAgICAKICAgICfou6LoqJjlhYjjga7jgrfjg7zjg4jjgpLnqbrjga7vvJHjg5rjg7zjgrjliIbjgpLjgrPjg5Tjg7zjgZfjgabjgIHmnIDlpKfjg5rjg7zjgrjmlbDliIbkvZzmiJDjgZnjgosKICAgIEZvciBwbm8gPSAyIFRvIG1heHAKICAgICAgICByb3cyID0gKHBubyAtIDEpICogMzUgKyAxCiAgICAgICAgQ2FsbCBjb3B5X3BhZ2Uod3MyLlJhbmdlKCJBMTpCUjM1IiksIHdzMi5SYW5nZSgiQSIgJiByb3cyKSkKICAgIE5leHQKICAgICfou6LoqJjlhYPjgYvjgonou6LoqJjlhYjjgbjvvJHvvZ7mnIDlpKfjg5rjg7zjgrjmlbDjgb7jgafou6LoqJjjgZnjgosKICAgIEZvciBwbm8gPSAxIFRvIG1heHAKICAgICAgICAnNuWIl+WIhuOBruODh+ODvOOCv+i7ouiomAogICAgICAgIEZvciBpID0gMCBUbyBVQm91bmQoRnJSb3cxKQogICAgICAgICAgICAn6Lui6KiY5YWD44CB6Lui6KiY5YWI44Gu6KGM55Wq5Y+344KS566X5Ye6CiAgICAgICAgICAgIHJvdzEgPSAocG5vIC0gMSkgKiAyMyArIEZyUm93MShpKQogICAgICAgICAgICByb3cyID0gKHBubyAtIDEpICogMzUgKyBUb1JvdzEoaSkKICAgICAgICAgICAgRm9yIGogPSAwIFRvIFVCb3VuZChGckNvbDEpCiAgICAgICAgICAgICAgICAn6Lui6KiY5YWD44CB6Lui6KiY5YWI44Gu5YiX5ZCN44KS566X5Ye6CiAgICAgICAgICAgICAgICBjb2wxID0gRnJDb2wxKGopCiAgICAgICAgICAgICAgICBjb2wyID0gVG9Db2wxKGopCiAgICAgICAgICAgICAgICAn6Lui6KiY5YWI44G46Lui6KiYCiAgICAgICAgICAgICAgICB3czIuQ2VsbHMocm93MiwgY29sMikuVmFsdWUgPSB3czEuQ2VsbHMocm93MSwgY29sMSkuVmFsdWUKICAgICAgICAgICAgTmV4dAogICAgICAgIE5leHQKICAgICAgICAnM+WIl+WIhuOBruODh+ODvOOCv+i7ouiomAogICAgICAgIEZvciBpID0gMCBUbyBVQm91bmQoRnJSb3cyKQogICAgICAgICAgICAn6Lui6KiY5YWD44CB6Lui6KiY5YWI44Gu6KGM55Wq5Y+344KS566X5Ye6CiAgICAgICAgICAgIHJvdzEgPSAocG5vIC0gMSkgKiAyMyArIEZyUm93MihpKQogICAgICAgICAgICByb3cyID0gKHBubyAtIDEpICogMzUgKyBUb1JvdzIoaSkKICAgICAgICAgICAgRm9yIGogPSAwIFRvIFVCb3VuZChGckNvbDIpCiAgICAgICAgICAgICAgICAn6Lui6KiY5YWD44CB6Lui6KiY5YWI44Gu5YiX5ZCN44KS566X5Ye6CiAgICAgICAgICAgICAgICBjb2wxID0gRnJDb2wyKGopCiAgICAgICAgICAgICAgICBjb2wyID0gVG9Db2wyKGopCiAgICAgICAgICAgICAgICAn6Lui6KiY5YWI44G46Lui6KiYCiAgICAgICAgICAgICAgICB3czIuQ2VsbHMocm93MiwgY29sMikuVmFsdWUgPSB3czEuQ2VsbHMocm93MSwgY29sMSkuVmFsdWUKICAgICAgICAgICAgTmV4dAogICAgICAgIE5leHQKICAgIE5leHQKICAgIHdiMS5DbG9zZQogICAgJ+aUueODmuODvOOCuOOCkuWFpeOCjOOCiwogICAgRm9yIHBubyA9IDIgVG8gbWF4cAogICAgICAgIHJvdzIgPSAocG5vIC0gMSkgKiAzNSArIDEKICAgICAgICB3czIuUmFuZ2UoIkJTIiAmIHJvdzIpLlBhZ2VCcmVhayA9IHhsUGFnZUJyZWFrTWFudWFsCiAgICBOZXh0CiAgICAn5Y2w5Yi356+E5Zuy6Kit5a6aCiAgICB3czIuUGFnZVNldHVwLlByaW50QXJlYSA9ICIkQSQxOiRCUiQiICYgbWF4cCAqIDM1CiAgICBBcHBsaWNhdGlvbi5TY3JlZW5VcGRhdGluZyA9IFRydWUKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKJzHjg5rjg7zjgrjliIbjga7jgrPjg5Tjg7wKUHJpdmF0ZSBTdWIgY29weV9wYWdlKEJ5VmFsIFNvdXJjZVJhbmdlIEFzIFJhbmdlLCBCeVZhbCBkZXN0aW5hdGlvblJhbmdlIEFzIFJhbmdlKQogICAgU291cmNlUmFuZ2UuQ29weQogICAgZGVzdGluYXRpb25SYW5nZS5QYXN0ZVNwZWNpYWwgeGxQYXN0ZUFsbAogICAgRGltIGkgQXMgTG9uZwogICAgV2l0aCBTb3VyY2VSYW5nZQogICAgICAgIEZvciBpID0gMSBUbyAuUm93cy5Db3VudAogICAgICAgICAgICAn44Kz44OU44O85YWD44Gu6KGM44Gu6auY44GV44KS5Y+W5b6X44GX44Gm44Kz44OU44O85YWI44Gu6KGM44Gu6auY44GV44KS6Kit5a6aCiAgICAgICAgICAgIGRlc3RpbmF0aW9uUmFuZ2UuUm93cyhpKS5Sb3dIZWlnaHQgPSAuUm93cyhpKS5Sb3dIZWlnaHQKICAgICAgICBOZXh0CiAgICBFbmQgV2l0aApFbmQgU3ViCgo=