|
オートフィルタですけど...。
Sub みかん()
Dim Rend As Long, Cend As Long, Cel As Range, AcSh As Worksheet
Set AcSh = ActiveSheet
Rend = AcSh.Cells(Rows.Count, "A").End(xlUp).Row
Cend = AcSh.Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
For Each Cel In AcSh.Range("A2", AcSh.Range("A65536").End(xlUp))
If Application.CountIf(AcSh.Range("A1", Cel), Cel.Value) = 1 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cel.Value
AcSh.Range("A1").Resize(, Cend).Copy Sheets(Cel.Value).Range("A1").Resize(, Cend)
AcSh.Range("A1:A" & Rend).AutoFilter Field:=1, Criteria1:=Cel.Value
AcSh.Range("A2:A" & Rend).Resize(, Cend).SpecialCells(xlCellTypeVisible).Copy
Sheets(Cel.Value).Range("A2").PasteSpecial
Sheets(Cel.Value).Range("A1").Select
AcSh.Range("A" & Rend).AutoFilter
End If
Next
Application.ScreenUpdating = True
End Sub
|
|