|
甘いスイカ さん、りんさん、MokoMokoさん
こんばんは。
似たようなことをしていたもんで
こんな感じではいかがでしょう。
違っていたらすみません。
Sub test()
Dim mySH1 As Worksheet
Dim mySH As Worksheet
Dim myR As Range
Dim sh As Worksheet
Dim myVal As Variant
Dim i As Integer
Application.ScreenUpdating = False
' 「シート1」以外のシートの削除
' For Each sh In ThisWorkbook.Worksheets
' If Not sh.Name = "シート1" Then
' Application.DisplayAlerts = False
' sh.Delete
' Application.DisplayAlerts = True
' End If
' Next
Set mySH1 = Worksheets("シート1")
Set myR = mySH1.Range("A1").CurrentRegion
myR.Columns(3).AdvancedFilter xlFilterCopy, _
copytorange:=mySH1.Range("Z1"), unique:=True
myVal = mySH1.Range("Z2", mySH1.Range("Z65536").End(xlUp)).Value
For i = 1 To UBound(myVal, 1)
Set mySH = Worksheets.Add(after:=Sheets(Sheets.Count))
mySH.Name = myVal(i, 1) & "のデータ"
With myR
.AutoFilter field:=3, Criteria1:=myVal(i, 1)
.Copy mySH.Range("A1")
.AutoFilter
End With
Next i
mySH1.Range("Z:Z").ClearContents
Application.ScreenUpdating = True
End Sub
|
|