【VBA】データを項目別にシート分割する方法

いつもお世話になっております。

タイトルの件で、質問させていただきます。

★前提
・1行目に、項目が入力されており、項目数・行数は毎回変わります。
・1行目と1列目に空白はありませんが、その他は空白セルもあります。

★やりたいこと
・1枚のシートで管理しているデータを、項目にフィルターをかけ、結果を別のシートに貼り付けたい(添付資料参照)。
・項目は、入力ボックスで自分で決めて、分割したいです。
・データの行数・列数に左右されないコードにしたい。

ネットで検索したサンプルを使って下記の様に作ってみましたが、オートフィルターの所でエラーが出てしまいます。


Dim wb As Workbook
Dim ws As Worksheet
Dim c, s As Variant, d As Variant
Dim rng As Range, i As Integer
Dim Lcol1 As Range, Lcol2 As Range
Dim Lrow As Long
Sub Bunkatu()
Set wb = ThisWorkbook
Set ws = wb.Worksheets("管理台帳検索")
Set Lcol1 = ws.Cells(1, Columns.Count).End(xlToLeft) '1行目最終セルの取得

'分割対象列が決まるか中止までループする
Do
s = InputBox("分割項目を入力してください。") '項目名取得
If s = "" Then Exit Sub '空白なら終了

Set rng = ws.Range(Cells(1, 1), Lcol1).Find(s, LookAt:=xlWhole) '項目名を1行目で探す
If Not rng Is Nothing Then Exit Do '見つけたら抜ける
MsgBox "項目名に[" & s & "]が見つかりません。"
Loop

If MsgBox("[" & rng.Value & "]で分割しますか？", vbYesNo) <> vbYes Then Exit Sub '最終確認
c = rng.Column '対象列

'指定列の重複しないデータの取得し、最終列の隣に追加する
Set Lcol2 = Lcol1.Offset(0, 1) '最終セルの隣

ws.Columns(c).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Lcol2, Unique:=True
d = ws.Range(Lcol2, Cells(Rows.Count, Lcol2.Column).End(xlUp)) '配列取得

For i = UBound(d) To 2 Step -1 'd配列の2行目から
Sheets.Add after:=ws
ActiveSheet.Name = d(i, 1)
ws.Range(Columns(1), Lcol1.EntireColumn).AutoFilter field:=c, Criteria1:=d(i, 1) '対象データをオートフィルタ
ws.AutoFilter.Range.Copy ActiveSheet.Range("A1") '抽出データを挿入
Next

ws.AutoFilterMode = False 'フィルター解除
End Sub

上のコードで、【ws.Range(Columns(1), Lcol1.EntireColumn).AutoFilter field:=c, Criteria1:=d(i, 1)】の部分で、エラーが出ます。
エラー内容は「実行時エラー’1004’:’Range’メソッドは失敗しました:'_Worsheet'オブジェクト」となっています。

いろいろ調べましたが、解決には至らず、こちらで質問させていただきました。
エラーの理由や修正方法を教えていただければ幸いです。
宜しくお願い致します。

No.1 ベストアンサー 回答者： bonaron 回答日時： 2018/10/13 07:54

確認してないけど、多分ここでしょう。

ws.Range(Columns(1), Lcol1.EntireColumn).AutoFilter field:=c, Criteria1:=d(i, 1)
　↓
ws.Range(ws.Columns(1), Lcol1.EntireColumn).AutoFilter field:=c, Criteria1:=d(i, 1)

この回答へのお礼

bonaron様

ありがとうございます！
無事作動しました(o*。_。)oペコッ

お礼日時：2018/10/13 13:22