明細を取引先ごとに別ブックへ分割して保存する

どんな場面で使うか

月末に、取引先ごとの取引明細を作って送付する、支店ごとのデータを各支店に配布する、といった作業があります。元の明細をフィルターで絞り込み、新しいブックに貼り付けて名前を付けて保存する、という手順を取引先の数だけ繰り返すのは手間がかかり、貼り付け先の取り違えも起きやすい作業です。

このマクロは、明細にどんな取引先があるかを自動で調べ、取引先ごとに1つのブックを作って保存します。取引先が増えてもコードを変える必要はありません。

前提とするデータ

「明細」シートの1行目が見出し、2行目からデータで、B列に取引先名が入っているものとします（列構成は説明用の例です）。保存先は、マクロのブックと同じフォルダに日付付きのフォルダを作って、その中に保存します。

コード

最初に取引先の一覧を Dictionary で作り、その一覧を1件ずつ取り出してオートフィルターで絞り込みます。見えている行だけを新しいブックにコピーし、取引先名をファイル名にして保存します。

Sub SplitByCustomer()
    Const KEY_COL As Long = 2                ' 取引先名の列（B列）
    Dim ws As Worksheet, newWb As Workbook, dic As Object, key As Variant
    Dim data As Variant, lastRow As Long, lastCol As Long, i As Long
    Dim outDir As String, savedCnt As Long, msg As String

    Set ws = ThisWorkbook.Worksheets("明細")
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    If lastRow < 2 Then MsgBox "明細がありません": Exit Sub

    ' 取引先の一覧を作る（A列から読むので1行だけでも2次元配列になる）
    Set dic = CreateObject("Scripting.Dictionary")
    data = ws.Range("A2").Resize(lastRow - 1, KEY_COL).Value
    For i = 1 To UBound(data, 1)
        key = Trim(CStr(data(i, KEY_COL)))
        If key <> "" And Not dic.Exists(key) Then dic.Add key, Empty
    Next i

    outDir = ThisWorkbook.Path & "\取引先別_" & Format(Date, "yyyymmdd") & "\"
    If Dir(outDir, vbDirectory) = "" Then MkDir outDir

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False        ' 同名ファイルは確認なしで上書き
    On Error GoTo ErrHandler

    For Each key In dic.Keys
        ws.Range("A1").Resize(lastRow, lastCol).AutoFilter Field:=KEY_COL, Criteria1:="=" & key
        Set newWb = Workbooks.Add(xlWBATWorksheet)
        ws.Range("A1").Resize(lastRow, lastCol).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=newWb.Worksheets(1).Range("A1")
        newWb.Worksheets(1).Name = "明細"
        newWb.Worksheets(1).Columns.AutoFit
        newWb.SaveAs Filename:=outDir & SafeFileName(CStr(key)) & ".xlsx", _
                     FileFormat:=xlOpenXMLWorkbook
        newWb.Close SaveChanges:=False
        Set newWb = Nothing
        savedCnt = savedCnt + 1
    Next key

Cleanup:
    On Error Resume Next
    If Not newWb Is Nothing Then newWb.Close SaveChanges:=False
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    On Error GoTo 0
    If msg <> "" Then msg = vbCrLf & "エラーで中断しました：" & msg
    MsgBox savedCnt & " / " & dic.Count & " 社分のブックを保存しました" & vbCrLf & outDir & msg
    Exit Sub

ErrHandler:
    msg = Err.Description
    Resume Cleanup
End Sub

' ファイル名に使えない記号を「_」に置き換える
Private Function SafeFileName(ByVal s As String) As String
    Dim ch As Variant
    For Each ch In Array("\", "/", ":", "*", "?", Chr(34), "<", ">", "|")
        s = Replace(s, ch, "_")
    Next ch
    SafeFileName = s
End Function

コードのポイント

取引先の一覧を先に作っておくのは、オートフィルターの条件に1社ずつ指定するためです。Dictionary はキーの重複を自動で除いてくれるので、明細に同じ取引先が何百行あっても、一覧には1回だけ登録されます。

フィルターの条件を「=取引先名」としているのは、完全一致で絞り込むためです。条件を取引先名だけにすると、通常は完全一致で動きますが、記号を含む名前などで意図しない結果になることがあるため、明示的に「=」を付けています。

SpecialCells(xlCellTypeVisible) で表示されている行だけをコピーしています。見出し行も表示されているので、新しいブックの1行目には見出しが入ります。コピー＆ペーストでは列幅が引き継がれないため、最後に AutoFit で列幅を整えています。

注意点

取引先名の表記揺れ（「（株）」と「株式会社」、全角と半角の空白など）があると、同じ会社が別のファイルに分かれてしまいます。分割する前に表記をそろえるか、取引先名ではなく取引先コードでフィルターするのが確実です。

• 取引先名に「*」や「?」が含まれると、フィルターではワイルドカードとして扱われる
• DisplayAlerts を False にしているため、同じ名前のファイルは確認なしで上書きされる
• 取引先が数百社ある場合は、ブックの作成と保存に時間がかかるので、事前に件数を確認する
• 分割したファイルを社外に送る場合は、ほかの取引先の情報が混ざっていないかを必ず確認する

応用：メール送付やPDF化と組み合わせる

分割したブックを取引先に送る場合は、取引先マスタにメールアドレスを持たせておき、保存したファイルを Outlook のメールに添付する処理を続けて行うと、送付作業までまとめて自動化できます。ただし、送信は取り消せないため、最初は下書き保存にとどめ、宛先と添付ファイルの組み合わせを目で確認してから送る運用をおすすめします。

受け取る側が Excel を必要としない場合は、SaveAs のかわりに ExportAsFixedFormat で PDF にして保存すると、数式や非表示の列が相手に渡る心配もなくなります。

ほかの記事