Sub 印刷表作成()

Dim INS, OUS, ENDROW, INR, OUR, OUEN, K, C, CM, R, MR, ML, ST

Application.ScreenUpdating = False

Set INS = Sheets("Sheet8")   '入力出力シート

Set OUS = Sheets("Sheet9")   '入力出力シート

 ENDROW = INS.Range("$A65536").End(xlUp).Row

    If ENDROW < 3 Then

        Exit Sub

    End If

MR = 3 '列数

CM = 3 '繰返し数

ML = 45 '1ページの行数

INR = Array("A", "B", "C", "A", "B", "C", "A", "B", "C") '入力列

OUR = Array("A", "B", "C", "E", "F", "G", "I", "J", "K") ''出力列

OUEN = 3 ''出力開始行

'OUS.Range("A”　&　OUEN　&":"&　"IV" &"65536"）.CLEARCONTENTS　'全消去

OUS.ResetAllPageBreaks '改ページ解除

ST = 3 '入力表開始行

Do

  For C = 1 To CM  '繰返し数

    For R = 1 To MR '列数

       K = LBound(INR) + (R - 1) + (C - 1) * MR

       INS.Range(INR(K) & ST & ":" & INR(K) & ST + ML - 1).Copy

       OUS.Range(OUR(K) & OUEN).PasteSpecial Paste:=xlValues

    Next R

    ST = ST + ML

  Next C

  OUEN = OUEN + ML

  OUS.HPageBreaks.Add Before:=OUS.Range("A" & OUEN)

Loop While ST <= ENDROW

End Sub

Sub 表転記()

Dim ins, ous, k, j

Set ins = Sheets("Sheet3")

Set ous = Sheets("Sheet4")

'

ing = Array(7, 5, 4, 6) '入力行または列

INR = Array("A", "D", "C", "B")  '入力列または行

oug = Array(4, 5, 6, 7) '出力行

OUR = Array("B", "D", "F", "H")  '出力列

For k = LBound(OUR) To UBound(OUR)

  For j = LBound(oug) To UBound(oug)

    Set oud = ous.Range(OUR(k) & oug(j))

    ''oud.Interior.ColorIndex = COL '色付

      oud.Value = ins.Range(INR(k) & ing(j)).Value

  Next j

Next k

Application.ScreenUpdating = True

End Sub