エクセルVBA:繰り返し処理について

エクセルVBA初心者です。
どうかご指導お願いします。
シート1に入力されたデータベースの
j列から特定のコードで絞り込んで新しいシートに貼り付け作業を22回(特定のコードが22個あるため)行う方法を教えて下さい。

下記コードは「特定のコードで絞り込んで、シート2に貼り付け」だけをしたものですが、このコードを応用して作りたいです。
ご指導お願いします。

Sub test01()
With sheets("sheet1").Range("A1")
.AutoFilter Field:10, Criterial:"1126"
.CurrentRegion.Copy Sheets("sheet2").Range("A1")

可能ならば、シートではなく、別ブックに抽出されると尚嬉しいです。
よろしくお願い致します。

No.1 ベストアンサー 回答者： しん14 回答日時： 2019/03/09 16:59

こんにちは。

ご希望条件を実装するためには、特定のコードを配列変数に格納する必要があります。
しかしながら、配列変数に格納した場合、Autofilterを繰り返し行う必要はなくなります。
それを踏まえて、以下のようなコードを書いてみました。


Sub sample()
Application.DisplayAlerts = False

Dim s1 As Worksheet, s2 As Worksheet, nbook As Workbook
Set s1 = ThisWorkbook.Sheets("sheet1")
Set s2 = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
s2.Name = "抽出シート"
Set nbook = Workbooks.Add

Dim list As Range, cls As Range
Set list = Range("「特定のコード」をリスト化している範囲")
ReDim codeary(1 To 1) As String

For Each cls In list
　　If codeary(UBound(codeary)) = "" Then
　　　　codeary(UBound(codeary)) = CStr(cls.Value)
　　Else
　　　　ReDim Preserve codeary(1 To UBound(codeary) + 1)
　　　　codeary(UBound(codeary)) = CStr(cls.Value)
　　End If
Next cls

With s1.Range("A1")
　　.AutoFilter Field:=10, Criteria1:=Array(codeary), Operator:=xlFilterValues
　　.CurrentRegion.Copy s2.Range("A1")
End With

s2.Copy before:=nbook.Sheets(1)
nbook.Sheets(Sheets.Count).Delete
nbook.SaveAs Filename:=ThisWorkbook.Path & "\抽出.xlsx", _
　　　　　　　　　　　　　FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
nbook.Close savechanges:=False

s1.Range("A1").AutoFilter
s2.Delete

Application.DisplayAlerts = True
End Sub

もし「特定のコード」をリスト化していないのであれば、
1. ReDim codeary(1 To 1) As String　→　ReDim codeary(1 To 22) As String
2. For Each ~ Nextを削除し、
　　codeary(1) = コード1個目
　　codeary(2) = コード2個目
　　・・・・・・
　　codeary(22) = コード22個目
としてください。

なお、新規ブックとしての保存は同じフォルダ内に「抽出.xlsx」としました。
変えたい場合は、「nbook.SaveAs Filename:=」以下を適宜変更してください。

この回答へのお礼

しん14さん
勉強不足にも関わらずご丁寧に教示頂きありがとうございました！大変助かりました。ベストアンサーとさせて頂きます。

お礼日時：2019/03/12 22:21