無料アプリで、すぐに、エクセルVBAマクロを作成できます。
例として、「フィルターで、リスト形式のデータを、項目別のシートに分ける」VBAマクロを作成します。
（ページの末尾に、VBAコード掲載）
事例
左の「データ」を、支店別に、右の「書式」に貼り付けます。
支店別に、「書式」に貼り付けました。
できました(^^♪
応用事例１
既存のシートがあるときは、既存データの下に貼り付けできます。
応用事例２
単票形式の表に、各データを差し込みたいときは、貼り付けデータを参照する関数を、差し込み場所に入力しておきます。（貼り付けデータは、単票の範囲外にします）
アプリの設定
アプリの設定です。
アプリのトップページ
⇒▼コピー・貼り付け
⇒リスト形式を
⇒【ツール】縦のリスト形式のデータを、項目別にシートに分ける
【ポイント】
■ 書式のある原本シートに貼り付けず、新しいシートに貼り付けた場合、値だけになります。
■ 転記先の原本シートには、見出しがあるので、「転記先の左上セル」は２行目（A2）にし、「転記データに見出しを含めない」に☑をいれます。
■ たとえば、下の例のように、原本に請求書のフォーマットを使うことができます
■ 上の例で、「指定した列を転記する」を選び、「B:F」と指定すると、
A列（納品先名）を除いた、B列からF列をコピーします。
作成されるコード
Sub デモ_94() '項目ごとに定型シート作成
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String
Sheets("データ").Select
'◆最終行を取得し、セル範囲を決める
With Range("a1:f1").CurrentRegion
右下セル = Cells(.Row + .Rows.Count - 1, Range("f1").Column).Address(False, False)
End With
セル範囲 = "a1" & ":" & 右下セルRange(セル範囲).Select
Call デモ_94_メイン処理(セル範囲)
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub
Sub デモ_94_メイン処理(セル範囲 As String)
Application.Calculation = xlCalculationManual '自動計算を停止
'◆キーをつくる
Dim 辞書 As Object, キー As Variant, 最終行 As Long, 行 As Long
Set 辞書 = CreateObject("Scripting.Dictionary")
最終行 = Sheets("データ").Cells(Rows.Count, Range("a1").Column).End(xlUp).Row
For 行 = Range("a1").Row + 1 To 最終行
キー = Sheets("データ").Cells(行, Range("a1").Column + 2 - 1).Value
If Not 辞書.Exists(キー) Then
辞書.Add キー, ""
End If
Next
'◆キーごとにデータを貼り付ける
For Each キー In 辞書
'◆フィルタ
Sheets("データ").Select
Range(セル範囲).AutoFilter Field:=2, Criteria1:=キー
'◆コピーする列の確定
Dim 重なり As Range
Set 重なり = Range(セル範囲).Offset(1, 0).Resize(Selection.Rows.Count - 1)
'◆シート名があるかチェック
Dim シート As Worksheet
For Each シート In Worksheets
If シート.Name = キー Then
'◆コピー
重なり.Copy
Sheets("データ").AutoFilterMode = False
Sheets(キー).Select
Range("a2").Select
'◆貼り付け行
Dim 左端列 As Long, 下端行 As Long, 相手セル As String
左端列 = ActiveCell.Column
下端行 = Selection.CurrentRegion.Row + Selection.CurrentRegion.Rows.Count - 1
相手セル = Cells(下端行, 左端列).Address(False, False)
If Range(相手セル).Value <> "" Then
相手セル = Cells(下端行 + 1, 左端列).Address(False, False)
End If
'◆貼り付け
Range(相手セル).PasteSpecial Paste:=xlPasteValues
GoTo 次の項目
End If
Next シート
Worksheets("書式").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = キー
'◆コピー
重なり.Copy
Sheets("データ").AutoFilterMode = False
'◆貼り付け
Sheets(キー).Range("a2").PasteSpecial Paste:=xlPasteValues
次の項目:
Next キー
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic ' 自動計算を再開
End Sub