全てのシートに同じ条件で処理をし保存するマクロ

質問

いつも識者の皆様にはお世話になっております。
Excel VBAのことで質問させてください。

ファイル名やその中のシートの数がばらばらで、データの型が同じファイルが毎日生成されます。
下記の流れでVBAで処理をしたいと思っています。
1.ファイルを開くダイアログを出し、ブックを指定する。
2.開いたブックにある全てのシートに対し、A列が"aaa"以外の行を削除する。
3.同じディレクトリに、ファイル名の前頭に"ccc"と付けて保存する。

しかし、それぞれのシートにはデータが20000-30000行あり、上記方法だとScreenUpdatingをfalseにしても時間がかかるという記述を見つけたため、
1.ファイルを開くダイアログを出し、ブックを指定する。
2.開いたブックにある全てのシートに対し、A列が「"aaa"と等しい」の条件でフィルタをかけ、そのデータを別の新しいブックに貼り付ける（シート名も同じにする）
3.ダイアログで開いたブックと同じディレクトリに、ファイル名の前頭に"bbb"と付けて保存する。

このような手順でやろうと思っていますが、ダイアログを出すところまではなんとかたどり着けたんですが、その後がまったくわかりません。

ご参考にならないとは思いますが、書きかけ（というかダイアログを出してworkbookを追加するだけ）のコードを添付いたします。

Sub test()

Dim OpenFileName As String
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
If OpenFileName <> "False" Then
Workbooks.Open OpenFileName
Else
MsgBox "キャンセルされました"
End If

Workbooks.Add

End Sub

識者の皆様、どうかご回答よろしくお願いいたします。

回答No.1

keithin · ベストアンサー

こんなカンジ：
sub macro1()
　dim myPath as string
　dim myFile as string
　dim s as worksheet

　myfile = application.getopenfilename()
　if myfile = "False" then
　　msgbox "cancel"
　　exit sub
　end if

　application.screenupdating = false
　application.calculation = xlcalculationmanual
　workbooks.open myfile
　mypath = activeworkbook.path & "\"
　myfile = "ccc" & activeworkbook.name

　for each s in activeworkbook.worksheets
　　s.autofiltermode = false
　　s.range("A:A").autofilter field:=1, criteria1:="<>aaa"
　　s.autofilter.range.offset(1).entirerow.delete shift:=xlshiftup
　　s.autofiltermode = false
　next

　activeworkbook.saveas filename:=mypath & myfile
　activeworkbook.close false
　application.calculation = xlcalculationautomatic
　application.screenupdating = true
　msgbox "DONE"
end sub

お礼

ありがとうございます！
できました！