VBA コード教えてください

質問

添付画像のように
配送日・出発地・目的地・運送会社・ドライバー　の５つの列からなるデータがあります（sheet1）

これは調べたい配送日でデータを抽出、さらに出発地＞運送会社＞ドライバーの順でソートをかけた物です

出発地ごとに分けたデータが欲しいという要望があり、下記のようなコードを作ってみました

Sub filter()
Worksheets("Sheet1").AutoFilterMode = False

With Cells(3, 1)
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "青森"
.AutoFilter Field:=2, Criteria1:="青森"
.CurrentRegion.Copy Destination:=Worksheets("青森").Cells(3, 1)

Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "秋田"
.AutoFilter Field:=2, Criteria1:="秋田"
.CurrentRegion.Copy Destination:=Worksheets("秋田").Cells(3, 1)

Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "岩手"
.AutoFilter Field:=2, Criteria1:="岩手"
.CurrentRegion.Copy Destination:=Worksheets("岩手").Cells(3, 1)

Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "宮城"
.AutoFilter Field:=2, Criteria1:="宮城"
.CurrentRegion.Copy Destination:=Worksheets("宮城").Cells(3, 1)

End With

Worksheets("Sheet1").AutoFilterMode = False

End Sub

これを実行すると青森・秋田・岩手・宮城のワークシートが作成され出発地ごとのワークシートの作成は出来ました

しかし、日によっては出発地が無い日がある事があります

そこでB列のデータを参照し、データが無い場合にはその出発地のワークシートは作成されないようにしたいと思いました

これが思ったようにいかないのです
どのようなコードを書けば、出発地データがある物だけワークシートを作成して個別のワークシートを作成させる事が出来るのでしょうか？

よろしくお願い致します

回答No.3

kkkkkm · ベストアンサー

> 実行時には、sheet１だけしかない状態で行うのですがエラーになるのです

標準モジュールにコードがあるみたいですね。シートモジュールだと思ってました。
以下のようにしてください。各RangeとCellsの前にドットを入れてます。抜けはないと思いますがもし抜けがあれば入れてください。

Sub Test()
Dim i As Long

With Worksheets("Sheet1")

.Range("B4", .Range("B4").End(xlDown)).Copy
.Range("G4").PasteSpecial (xlPasteAll)
.Range("G4", .Range("G4").End(xlDown)).RemoveDuplicates Columns:=Array(1), Header:=xlNo

For i = 4 To .Cells(Rows.Count, "G").End(xlUp).Row
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = .Cells(i, "G").Value
.Cells(3, 1).AutoFilter Field:=2, Criteria1:=.Cells(i, "G").Value
.Cells(3, 1).CurrentRegion.Copy Destination:=Worksheets(.Cells(i, "G").Value).Cells(3, 1)
.AutoFilterMode = False
Next

End With

End Sub

お礼

はい、標準モジュールを使っていました

教えて頂いたコードを実行させた所希望どうりの事が出来るようになりました

どうもありがとうございました

回答No.4

imogasi

すでに回答は出ているが、方法論として全体的な、見通しの勉強のために
挙げてみます。
同類の列データから、重複のないリストを作る方法（ＶＢＡ）は（ロジックは）
（１）CountifをVBAで使う方法（下記）一番考えやすいかな？
（２）ＦｉｌｔｅｒのＵｎｉｑｕｅ指定
（３）ＦＳＯのＤｉｃｔｉｏｎａｒｙの仕組を使う
（４）ＳＱＬのＵｎｉｑｕｅ指定
（５）データ総なめで、既に存在するか判別を繰り返す法
などあり、データ処理の必須の基礎手法です。
ーー
Ｂ列に府県名があるとして
標準モジュールに
Sub test01()
Dim fuken(100)
k = 1
lr = Range("B100000").End(xlUp).Row
For i = 2 To lr
x = Cells(i, "B")
If WorksheetFunction.CountIf(Range("b2:B" & i), x) = 1 Then
fuken(k) = x
k = k + 1
End If
Next i
'--確認用　府県が多い場合はＤｅｂｕｇＰｒｉｎｔに置き換え
For i = 1 To k - 1
MsgBox fuken(i)
Next i
'---
For i = 1 To k - 1
Worksheets.Add(After:=ActiveSheet).Name = fuken(i)
Next i
End Sub
を入れて実行すると、存在する府県名のシートが（出現順に）できます。
ーー
この後、ＶＢＡで府県名でＦｉｌｔｅｒを使って、各府県の各シートに振り分けるのは、１０行程度のコードでできます。

お礼

書いていただいたコード実行した所、希望しているようにシートが作成されてシートの名前も希望通リ出発地の名前のシートに変更されました

コメント頂いたお二人とも変数使ってコード作成するので、私がネット参照しながら作る物とは違ってスマートな物になってますね
私ももっと勉強して理解できるようになりたいです

今回はどうもありがとうございました

回答No.2

kkkkkm

> 実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです

2度目だと、すでに存在するシート名と同じシート名にしようとしてエラーになっています。
元のコードでも同じですので、毎回削除するとかするのだと思っていたのですが。

補足

実行時には、sheet１だけしかない状態で行うのですがエラーになるのです

つまり毎回Sheet１に会社のシステムからExcel形式でエクスポートしたファイルからデータをコピーして貼り付け

この貼り付けたデータを、抽出したい日付のデータのみ残すようにしてから、出発地＞運送会社＞ドライバーの順でソートをかけた状態にする

なので、sheet１だけしか存在しないブック構成なのです

ここから教えて頂いた方法で、B列のデータを重複しないようにしたデータをG4から貼り付けます

ここまで出来た状態で、教えて頂いたコードを実行させるのですが、
実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです
になってしまうのです

回答No.1

kkkkkm

Findで出発地を検索して見つかればシート作成やコピーなどの操作をするという方法があります。以下のサイトのサンプル 2を参考にしてください。
条件に当てはまるセルを検索する(Find/FindNext/FindPreviousメソッド)
https://www.moug.net/tech/exvba/0050116.html

また、出発地のデータを重複の削除で出発地一覧を空いている場所に作成してその一覧を参照してシート作成やコピーをするとう手もあります。
たとえばG4から下に一覧を作成したとして
(一覧の作成のコードはマクロの記録で取得して最初に入れてください)

Sub Test()
Dim i As Long

With Cells(3, 1)
For i = 4 To Cells(Rows.Count, "G").End(xlUp).Row
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Cells(i, "G").Value
.AutoFilter Field:=2, Criteria1:=Cells(i, "G").Value
.CurrentRegion.Copy Destination:=Worksheets(Cells(i, "G").Value).Cells(3, 1)
Worksheets("Sheet1").AutoFilterMode = False
Next
End With
End Sub

補足

kkkkkmさんコメントありがとうございます

教えて頂いた、別なセルにデータの重複を削除した物を作成し、それを参照させるという手法を行ってみました

コードは下記のようにしました

Sub Test()
Dim i As Long

Range("B4", Range("B4").End(xlDown)).Copy
Range("G4").PasteSpecial (xlPasteAll)
Range("G4", Range("G4").End(xlDown)).RemoveDuplicates Columns:=Array(1), Header:=xlNo

With Cells(3, 1)
For i = 4 To Cells(Rows.Count, "G").End(xlUp).Row
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Cells(i, "G").Value
.AutoFilter Field:=2, Criteria1:=Cells(i, "G").Value
.CurrentRegion.Copy Destination:=Worksheets(Cells(i, "G").Value).Cells(3, 1)
Worksheets("Sheet1").AutoFilterMode = False
Next
End With
End Sub

これを実行すると
ActiveSheet.Name = Cells(i, "G").Value
の部分で
実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです
になってコードが止まってしまうのですが、これはどうやったらエラー回避できるのでしょうか