各シートへの振分け

Sub シートへの振分け()

'画面停止
Application.ScreenUpdating = False

  Dim i As Long
  
  'すべてのシートに実行
  For i = 1 To Sheets.Count
   
    With Worksheets("マスタシート").Range("A2").CurrentRegion
       
         '1列目をシート名でフィルターをかける
        .AutoFilter Field:=1, Criteria1:=Sheets(i).Name
        
         '絞り込んだ行が1より大きい場合は
         If WorksheetFunction.Subtotal(3, Range("A:A")) > 1 Then
         
            'A列を非表示
            Range("A1").EntireColumn.Hidden = True
          
            '各シートの最終行の1行下にコピーする
           .Resize(.Rows.Count - 1).Offset(1).Copy
           
           Sheets(i).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
           
           Application.CutCopyMode = False
           
         End If
           
    End With
  
  Next i
 
  'オートフィルタの解除
  Worksheets("マスタシート").Range("A2").CurrentRegion.AutoFilter
  
  'A列を表示
  Range("A1").EntireColumn.Hidden = False
  
'画面停止解除
Application.ScreenUpdating = True

'マスタシートに戻る

Worksheets("マスタシート").Range("A2").Select

'完了メッセージの表示
MsgBox "完了"

End Sub