ランダムに並んでいるExcelファイルのデータを複数のファイルに分割する

Option Explicit

Sub Export_ExcelFile()

    '分割元ブックを格納する変数の定義
    Dim TWB As Workbook 'このブック
    
    '3ファイルに分割することを前提にリストの数を3とする
    Const w As Integer = 3
    
    '分割先ワークブックを格納する変数をリスト形式で定義
    Dim WB(1 To w) As Workbook
    
    'ファイル名を格納する変数をリスト形式で定義
    Dim FileNam(1 To w) As String
    
    '出力先のパスを格納する変数を定義
    Dim xPath As String
    
    'ファイルを分けるキーとなる変数を定義
    Dim key As String
    
    '分割元データカウント変数を定義
    Dim i As Integer
    Dim n As Integer
    
    '分割ファイル別カウント変数
    Dim t As Integer
    Dim s As Integer
    Dim e As Integer

    'ファイル別カウント変数の初期値を格納
    t = 6
    s = 6
    e = 6
   
    '分割元ワークシート変数定義
    Dim Sh1 As Worksheet
    
    '分割元ワークシートを指定する
    Set Sh1 = ThisWorkbook.Worksheets("通勤手当一覧")
    
    '分割先ワークシート変数定義
    Dim ShT1(1 To w) As Worksheet
    
    '分割元のExcelブックを変数にセット
    Set TWB = ThisWorkbook
    'Set TWB = ActiveSheet  '元シートをActiveSheetにセットする
    
    '分割ファイル出力先のパスを指定
    With ActiveWorkbook
       xPath = .Path & "\"  'ファイルが置いてあるフォルダからのパスを指定
    End With
    
    '新規ブック作成
    For n = 1 To 3
      Set WB(n) = Workbooks.Add
    Next n
    
    '分割先ブックのシート名を設定
    For n = 1 To 3
     WB(n).Sheets("Sheet1").Name = "通勤手当一覧"
    Next
    
    '分割先ワークシートを指定
    For n = 1 To 3
      Set ShT1(n) = WB(n).Worksheets("通勤手当一覧")
    Next

     'ファイル出力日を取得
    Dim strDate As String
    strDate = DateSerial(Year(Now), Month(Now) - 1, 1)
    strDate = Format(strDate, "yyyymm")

     'Excelファイル出力先パスを指定
    FileNam(1) = xPath & "東京都" & "_" & strDate & ".xlsx"
    FileNam(2) = xPath & "埼玉県" & "_" & strDate & ".xlsx"
    FileNam(3) = xPath & "新潟県" & "_" & strDate & ".xlsx"

     'タイトル欄を分割先ブックのシートにコピー
    For n = 1 To 3
     Sh1.Range(Sh1.Cells(5, 2), Sh1.Cells(5, 7)).Copy ShT1(n).Range("B5")
    Next


 'データ部分ループ処理 *******************************
 
    'データの始まり6行目を指定
    Dim start As Long
    start = 6
 
    '社員Noが続く間はループ
    Do While Sh1.Cells(start, 2).Value <> ""
 
    '分割元の最初の勤務地を取得
    key = Sh1.Cells(start, 6).Value

    '勤務地が東京都だったら、東京都用のファイルにデータをコピー
    If key = "東京都" Then
      'データ行コピー
      Sh1.Range(Sh1.Cells(start, 1), Sh1.Cells(start, 7)).Copy ShT1(1).Range("A" & t)
      'カウント
      t = t + 1
    End If

    '勤務地が埼玉県だったら、埼玉県用のファイルにデータをコピー
    If key = "埼玉県" Then
     'データ行コピー
      Sh1.Range(Sh1.Cells(start, 1), Sh1.Cells(start, 7)).Copy ShT1(2).Range("A" & s)
     'カウント
      s = s + 1
    End If

    '勤務地が新潟県だったら、新潟県用のファイルにデータをコピー
    If key = "新潟県" Then
      'データ行コピー
      Sh1.Range(Sh1.Cells(start, 1), Sh1.Cells(start, 7)).Copy ShT1(3).Range("A" & e)
     'カウント
      e = e + 1
    End If

     '分割元のデータ行を1つ下にずらす。
    start = start + 1
    
    Loop

  '****************************************************

  For n = 1 To 3
  
   '分割したファイルの各列を文字幅に合わせる。
   WB(n).Worksheets("通勤手当一覧").Range("B:G").Columns.AutoFit
      
   '分割したファイルを保存して閉じる
   WB(n).SaveAs Filename:=FileNam(n)
   WB(n).Close
     
   '分割ファイルのブックを解放
   Set WB(n) = Nothing

  Next

 '終了メッセージ
  MsgBox "分割処理が完了しました。"

End Sub