（追加中）転記系テンプレート ExcelVBA

Option Explicit

Type ShObj
  A As Worksheet
  B As Worksheet
  C As Worksheet
End Type
Dim Sh As ShObj

Type RngObj
  Og As Range  'Origin
  Tg As Range  'Target
  C As Range
End Type
Dim Rng As RngObj

Type 先頭データ行
  Og As Long  'Origin
  Tg As Long  'Target
  C As Long
End Type
Dim rH As 先頭データ行

Enum cOg  'Origin
  あ = 1
  い
  う
  え
  お
End Enum
Enum cTg  'Target
  か = 1
  き
  く
  け
  こ
End Enum

Sub 行列転置して飛び飛び範囲転記()
  On Error GoTo Err
  Set Rng.Og = Application.InputBox("転記したい範囲を選択して下さい。", "", Type:=8)
  Set Rng.Tg = Application.InputBox("転記先の最初のセルを選択して下さい。", "", Type:=8)

  Application.ScreenUpdating = False
  Dim i
  For i = 1 To UBound(Rng.Og.Value2)
    Rng.Tg.Cells(cTg.か, i).Value = Rng.Og(i, cOg.お).Value
    Rng.Tg.Cells(cTg.き, i).Value = Rng.Og(i, cOg.あ).Value
    Rng.Tg.Cells(cTg.く, i).Value = Rng.Og(i, cOg.う).Value
    Rng.Tg.Cells(cTg.け, i).Value = Rng.Og(i, cOg.い).Value
    Rng.Tg.Cells(cTg.こ, i).Value = Rng.Og(i, cOg.え).Value
  Next
Err:
  Application.ScreenUpdating = True
End Sub

Sub 飛び飛び範囲転記()
  On Error GoTo Err
  Set Rng.Og = Application.InputBox("転記したい範囲を選択して下さい。", "", Type:=8)
  Set Rng.Tg = Application.InputBox("転記先の最初のセルを選択して下さい。", "", Type:=8)

  Application.ScreenUpdating = False
  Dim i
  For i = 1 To UBound(Rng.Og.Value2)
    Rng.Tg.Cells(i, cTg.か).Value = Rng.Og(i, cOg.お).Value
    Rng.Tg.Cells(i, cTg.き).Value = Rng.Og(i, cOg.あ).Value
    Rng.Tg.Cells(i, cTg.く).Value = Rng.Og(i, cOg.う).Value
    Rng.Tg.Cells(i, cTg.け).Value = Rng.Og(i, cOg.い).Value
    Rng.Tg.Cells(i, cTg.こ).Value = Rng.Og(i, cOg.え).Value
  Next
Err:
  Application.ScreenUpdating = True
End Sub


Sub 連続範囲転記()
  On Error GoTo Err
  Set Rng.Og = Application.InputBox("転記したい範囲を選択して下さい。", "", Type:=8)
  Set Rng.Tg = Application.InputBox("転記先の最初のセルを選択して下さい。", "", Type:=8)

  Application.ScreenUpdating = False
  Dim i, j
  For i = 1 To UBound(Rng.Og.Value2)
    For j = cTg.あ To cTg.う
      Rng.Tg.Cells(i, j).Value = Rng.Og(i, j).Value
    Next
  Next
Err:
  Application.ScreenUpdating = True
End Sub