| |
▼えりおっと さん：
おはようございます。
以下の条件で作成しました。
シートは２行目が項目の行
フィルターは２列目(つまりB2です）
仕上がりのシートの大きさが分からないので、Z3000のセルのところで
フィルター結果を一旦表示させています。
A1とA4を作業用に使用しています。
標準のモジュールに貼り付けて試してみてください。
Sub Filterとsheet作成()
' Application.ScreenUpdating = False
Dim i As Integer
Dim ST_Name As String
Range("Z3000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("AA").Select
Range("B2", Cells(65536, 2).End(xlUp)).Select
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Selection.SpecialCells(xlCellTypeVisible).Copy
Range("Z3000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
For i = Cells(65536, 26).End(xlUp).Row To 3001 Step -1
Range("E1") = Cells(i, 26).Value
ST_Name = Range("E1")
del_sheet ST_Name
Sheets("AA").Activate
Range("A2").AutoFilter Field:=2, Criteria1:=Range("E1")
Range("A2").CurrentRegion.Select
Selection.Copy
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = ST_Name
Range("A1") = ST_Name
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("AA").Activate
Selection.AutoFilter
Next
Range("A1").Select
' Application.ScreenUpdating = True
End Sub
Sub del_sheet(ST_Name As String)
On Error Resume Next
Application.DisplayAlerts = False
Sheets(ST_Name).Delete
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
とりあえずこれで大体のことが出来ていると思いますが･･･
また識者から知恵を拝借してください・・・
|
|
Mi
- 05/10/15(土) 7:33 -
