|
▼ベニー さん:
少し修正しました
Sub Try2()
Dim WS2 As Worksheet
Dim rr As Range, aList As Range, c As Range
Dim n As Long, nSheet As Long
With Worksheets("Sheet1") 'A列の一意な番号リストを作成(範囲aList)
Set rr = .Range("A1").CurrentRegion
rr.Columns(1).AdvancedFilter xlFilterCopy, , .Range("BB1"), True
Set aList = .Range("BB1").CurrentRegion
End With
For nSheet = 2 To aList.Count
n = Worksheets.Count
If nSheet > n Then 'シートがないとき
Set WS2 = Worksheets.Add(After:=Worksheets(n))
Else
Set WS2 = Worksheets(nSheet) 'シートがあるとき
WS2.UsedRange.ClearContents
End If '抽出Copy
rr.AdvancedFilter xlFilterCopy, aList.Resize(2), WS2.Range("A1")
WS2.Name = aList.Item(2).Value '抽出した番号をSheet名に
WS2.Columns.AutoFit '列幅AutoFit
aList.Item(nSheet + 1).Copy aList.Item(2)
Set WS2 = Nothing
Next
aList.Clear
End Sub
|
|