【VBA】特定の列にある客先名毎にシートを追加し振り分ける

受注した注文内容から客先別のリストを作る為、
客先別にシートを振り分けるマクロを作って欲しいとの要望があったので、サンプルコードを作りました。

列Bにある客先名をシート一覧にして、データをそれぞれ振り分けます。

シートオブジェクトdataSheetには、以下のような大本のデータが入ったシートを設けて下さい。

変数sortingColomnに振り分けたい要素がある列を指定します。
ここでは、列B「客先」を振り分けたいので、sortingColomn = 2　としています。
　　　　　　　　　↓

※このデータはCSVファイルを引用している為客先名もそれほど多くなく、スペルが違っていたりすることもないのですが、
同じ客先で大文字と小文字が混同していたり、客先名の数が膨大だった場合シート数もそれだけ多くなります。
なので手入力で作ったデータを振り分けた場合、シート数が数百になるなんてこともあり得るので注意して下さい。

その場合は新たに列を設けて振り分け№を指定する等することをお勧めします。

データのヘッダーが複数行ある場合は、
dataSheet.Range("1:1," & i & ":" & i).Copy 'ヘッダーを含む行のコピー　の部分を
dataSheet.Range("1:3," & i & ":" & i).Copy 等適宜変更して下さい。

Sub SortingSheetRow()

    Dim dataSheet As Worksheet
    Dim maxRow As Long, maxCol As Long 'ペースト元の最終行、最終列
    Dim pasteSheetMaxRow As Long 'ペースト元の最終行
    Dim addSheetName As String '追加するシートの名前
    Dim sortingColomn As Integer '振り分けたい名前が存在する列

    Set dataSheet = Worksheets("dataSheet")

    maxRow = dataSheet.Cells(Rows.Count, 1).End(xlUp).Row
    maxCol = dataSheet.Cells(1, Columns.Count).End(xlToLeft).Column

    sortingColomn = 2 '振り分けたい列を指定する

    Application.ScreenUpdating = False '描画停止

    dataSheet.Select

    'ヘッダーを除く行から開始する
    For i = 2 To maxRow
        addSheetName = Cells(i, sortingColomn).Value
        Select Case SheetSarch(addSheetName) '客先名のシートがあるか判定

        Case 1 'シートがある場合
            dataSheet.Rows(i & ":" & i).Copy
            Worksheets(addSheetName).Select
            pasteSheetMaxRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Rows(pasteSheetMaxRow & ":" & pasteSheetMaxRow).Select
            ActiveSheet.Paste

        Case 2 'シートがない場合
            dataSheet.Range("1:1," & i & ":" & i).Copy 'ヘッダーを含む行のコピー
            Worksheets.Add.Name = addSheetName '新規シートの追加
            Rows("1:1").Select
            ActiveSheet.Paste
        End Select

       dataSheet.Select

    Next
    Application.ScreenUpdating = True

End Sub


Function SheetSarch(sarchStr As String) As Integer
'ワークシートの名前を引数sarchStrの内容で検索する
    For Each i In Worksheets
        If i.Name = sarchStr Then
            SheetSarch = 1 'シートがある場合
            Exit Function
        End If
    Next
    SheetSarch = 2 'シートがない場合
End Function

実行結果

実行すると、以下の画像のように客先毎にシートが追加され、データが振り分けられます。