社員名簿からリストで指定した部署ごとに名簿を抜き出して分割したワークシートを作るマクロ

こういう名簿から

リストシートに記入された部署名に従って

部署ごとの

ワークシートに

分割するマクロ

コード

Sub 名簿をリストに沿って分割する()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim listlastrow As Long
    Dim filterColumn As Range
    Dim filterValue As String
    Dim lastRow As Long
    Dim i As Long
    Dim ii As Long
    
    ' 大元のワークシートを指定
    Set ws1 = Sheets("名簿")
     
     ' フィルターをクリア
    ws1.AutoFilterMode = False
    
    'リストの最終行を取得
    listlastrow = Sheets("リスト").Range("A1").CurrentRegion.Rows.Count
    
    '繰り返しの指定
    For i = 1 To listlastrow
    
    ' フィルターの条件を指定（指定の文字列以外を削除）
    filterValue = Sheets("リスト").Cells(i, 1)
    
    '大元のシートを、最後にコピーする
    ws1.Copy After:=Worksheets(Worksheets.Count)
    'コピーしたシートをws2とする
    Set ws2 = Worksheets(Worksheets.Count)
   
    ' フィルターをかける列を指定
    Set filterColumn = ws2.Range("A:A") ' 列Aを対象とする場合
    ' 最終行を取得
    lastRow = ws2.Cells(ws2.Rows.Count, filterColumn.Column).End(xlUp).Row
    
    ' オートフィルターモードを有効にしてフィルターを設定
    filterColumn.AutoFilter Field:=1, Criteria1:="<>" & filterValue
    
    ' フィルターされた行を削除
    For ii = lastRow To 2 Step -1 'タイトルを入れている場合は2を消したい最初の行に変更
        If Not ws2.Cells(ii, filterColumn.Column).EntireRow.Hidden Then
            ws2.Rows(ii).Delete
        End If
    Next ii
    
    ' オートフィルターモードをクリア
    ws2.AutoFilterMode = False
    
    'ワークシートの名前を部署名に変える
    ws2.Name = filterValue
    
    Next i
End Sub