Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

54953 / 76732

←次へ　｜　前へ→


	【26562】Re:オートフィルター抽出結果を別シートへ

ponpon - 05/7/10(日) 9:33 -


	引用なし

	パスワード

甘いスイカさん、りんさん、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

0 hits

▼

【26542】オートフィルター抽出結果を別シートへ 甘いスイカ 05/7/8(金) 12:18