フィルター→新規ブックにコピペ→同じ階層に保存

キャリアがドコモとなっているデータを抽出して、新しいブックとして保存する。

保存先はマクロブックと同じ階層。「処理済」というフォルダを作成してその中に保存する。

f:id:abv72:20210813170145p:plain

Sub wrk()

　Dim wb As Workbook
　Dim st As String
　Dim strPath As String

　'同じ階層に「処理後」というフォルダを作成する
　strPath = ThisWorkbook.Path & "￥処理後"
　If (Dir(strPath, vbDirectory) = "") Then
　　MkDir (strPath)
　End If

　st = "ドコモ"

　Sheets("コピペ用").Cells.Clear

　Sheets("データ").AutoFilterMode = False

　'フィルターでデータ抽出
　With Sheets("データ").Range("A1")

　　.AutoFilter field:=11, Criteria1:=st
　　.CurrentRegion.Copy
　　Sheets("コピペ用").Range("A1").PasteSpecial xlPasteValues
　　Application.CutCopyMode = False
　　.AutoFilter

　End With

　'抽出したデータを新しいブックにして保存
　Sheets("コピペ用").Copy
　Set wb = ActiveWorkbook

　With wb

　　.Sheets(1).name = st 'シート名変更
　　.SaveAs (ThisWorkbook.Path & "￥処理後￥" & st) 'マクロブックと同じ階層
　　.Close savechanges:=True '保存して閉じる

　End With

End Sub