シート分割

シートのA列の内容ごとにシートを分割します。

scripting.dictionary にて分割リストを作成後、そのリストを用いてオートフィルターとコピーを繰り返して
新しいシートへコピーを行います。
シート名称にはフィルターに使用した文字列が設定されます。

 Private Sub AFLC()  
 Dim myDic As Object     'Dictionary  
 Dim FilList() As Variant  'オートフィルターリスト  
 Dim YN As Integer    '確認用  
 Dim i As Long       'カウント  
 Dim r As Long       'カウント  
 Dim m As Long      'カウント  
 Dim myFileName As String    '自ファイル名  
 Dim myPath As String       '自ファイルパス  
 Dim NewSheetName As String '新シート名  
 On Error GoTo er  
 '処理対象シートの確認  
   YN = MsgBox("処理対象ブック名 : " & ActiveWorkbook.Name & vbCrLf & "処理対象シート名 : " & ActiveSheet.Name, vbYesNo)  
   If YN = vbNo Then Exit Sub  
   myFileName = ActiveWorkbook.Name  'ブック名取得  
   NewSheetName = ActiveSheet.Name   'シート名取得  
   Application.ScreenUpdating = False '画面更新停止  
 'オートフィルタリストの作成  
   m = Range("A2").SpecialCells(xlCellTypeLastCell).Row  
   Set myDic = CreateObject("scripting.dictionary")  
   r = 0  
   For i = 2 To m  
     Application.StatusBar = "リスト作成中(" & i & "/" & m & ")"  
     If Not myDic.Exists(CStr(Range("A" & i))) Then  
       myDic.Add CStr(Range("A" & i)), r  
       r = r + 1  
     End If  
   Next i  
   FilList = myDic.keys   'リスト代入  
   Set myDic = Nothing   '開放  
 'オートフィルタとコピー  
   With Workbooks(myFileName).Worksheets(NewSheetName).Range("A1")  
     For i = 0 To UBound(FilList, 1) - 1  
       Application.StatusBar = "シート分割中(" & i & "/" & UBound(FilList, 1) - 1 & ")"  
       Workbooks(myFileName).Worksheets.Add ActiveSheet  
       Workbooks(myFileName).ActiveSheet.Name = CStr(FilList(i))  
       Workbooks(myFileName).Worksheets(NewSheetName).Select  
       .AutoFilter 1, CStr(FilList(i))  
       .CurrentRegion.SpecialCells(xlVisible).Copy Workbooks(myFileName).Worksheets(CStr(FilList(i))).Range("A1")  
       .AutoFilter  
     Next i  
     Application.ScreenUpdating = True  '画面更新再開  
     Application.StatusBar = False  
   End With  
   Exit Sub  
 er:  
 MsgBox Err.Description & "(" & Err.Number & ")"  
 End Sub
ラベル: ,