顧客情報を条件に応じてシートに転記

質問

宜しくお願いします。

A～Lまで以下の順で顧客情報が並んでいて、約400行並んでいます。
番号，名称，住所，区分,担当，曜日(月～土まで)，その他

現在はこのデータをオートフィルタを使い、担当+曜日毎に絞込みをかけて、担当別のブックに転記していますが、
データ追加のたびにコピー、ペーストで転記するのもかなり手間がかかります。
そこで、上記でやっていることをVBAで組むのは可能でしょうか？
仕様は同ブックのシートでも別ブックでも構いません。
ご教授いただければと思います。

また、拙い説明なので、分かりにくい点や不足している情報等があればご説明させていただきます。

回答No.4

n-jun · ベストアンサー

>担当：伊藤の月曜に○の入った箇所のみをシートに抽出するという形になります。
例えば、担当：伊藤さんに○がない日でもシートを作成してよければ、
（空白があっても）

Sub Test2()
Dim Dic As Object
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim r1 As Range, r2 As Range
Dim rr As Range
Dim i As Integer
Dim shname As String
Dim v, vv, mykey

Set Dic = CreateObject("Scripting.Dictionary")
Set WS1 = Worksheets("Sheet1")

Application.ScreenUpdating = False

With WS1
v = .Range(.[E2], .Cells(Rows.Count, "E").End(xlUp)).Value
For Each vv In v
If Not Dic.exists(vv) Then
Dic(vv) = Empty
End If
Next

For Each mykey In Dic.keys
For i = 6 To 11

Set rr = .Range(.[A1], .Cells(Rows.Count, 1).End(xlUp).Resize(, 12))
rr.AutoFilter
rr.AutoFilter 5, mykey
rr.AutoFilter i, ("<>")

Set r1 = .Range(.[A1], .Cells(Rows.Count, 5).End(xlUp))
Set r1 = Union(r1, Intersect(r1.EntireRow, .Columns(i)), Intersect(r1.EntireRow, .Range("L:L")))

shname = mykey & "の" & .Cells(1, i).Value

On Error Resume Next
Application.DisplayAlerts = False
Worksheets(shname).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WS2 = ActiveSheet
WS2.Name = shname

r1.Copy
WS2.Range("A1").PasteSpecial
Application.CutCopyMode = False
rr.AutoFilter
Next

Set r1 = Nothing
Set rr = Nothing
Set WS2 = Nothing
Next

End With
Application.ScreenUpdating = True
End Sub
こんな感じですかね。

○のない日はシートも作らないのであれば、また検証します。

お礼

実は一週間以上試行錯誤を繰り返していて、
まさか一日で解決できるとは思ってもいませんでした。
大変ありがとうございます。

これからはこの構文を理解し、自分の糧に出来るよう励みたいと思います。
本当ありがとうございました。

回答No.3

n-jun

ANo.2です。

r1.Copy
WS2.Range("A1").PasteSpecial
Next
ここを

r1.Copy
WS2.Range("A1").PasteSpecial
Application.CutCopyMode = False
Next
のようにしておいて下さい。

回答No.2

n-jun

>担当Aの月曜
既にシートが存在していても、強制的に削除し作り直します。
”月曜”については、【曜日(月～土まで)】の項目名を使用しています。
同じブックにシートを作成します。

ファイルのコピーを作成し、実行をお願いします。

Sub Test()
Dim Dic As Object
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim r1 As Range, r2 As Range
Dim rr As Range
Dim i As Integer
Dim shname As String
Dim v, vv, mykey

Set Dic = CreateObject("Scripting.Dictionary")
Set WS1 = Worksheets("Sheet1")

Application.ScreenUpdating = False

With WS1
v = .Range(.[E2], .Cells(Rows.Count, "E").End(xlUp)).Value
For Each vv In v
If Not Dic.exists(vv) Then
Dic(vv) = Empty
End If
Next

For Each mykey In Dic.keys
Set rr = .Range(.[A1], .Cells(Rows.Count, 1).End(xlUp).Resize(, 12))
rr.AutoFilter
rr.AutoFilter 5, mykey
For i = 6 To 11
Set r1 = .Range(.[A1], .Cells(Rows.Count, 5).End(xlUp))
Set r1 = Union(r1, Intersect(r1.EntireRow, .Columns(i)), Intersect(r1.EntireRow, .Range("L:L")))

shname = mykey & "の" & .Cells(1, i).Value

On Error Resume Next
Application.DisplayAlerts = False
Worksheets(shname).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WS2 = ActiveSheet
WS2.Name = shname

r1.Copy
WS2.Range("A1").PasteSpecial
Next

rr.AutoFilter
Set r1 = Nothing
Set rr = Nothing
Set WS2 = Nothing
Next

End With
Application.ScreenUpdating = True
End Sub

補足

ありがとうございます。
シートが一気に増えたのを見たときには驚きでした。

ただ、教えていただいたものを実行してみると担当している店舗を全て抽出してしまい、
余分な空白セルが入ってしまいます。曜日の欄は全て記入があるわけではなく、特定の曜日に○が記入されています。
この余分な空白セルも消し、○が記入されている箇所のみを抽出することは可能でしょうか？
例(ズレてしまうので×を空白を×で代用しています。)

名称・・・・担当,月,火,水,木,金,土,その他
A店・・・・・伊藤,○,×,○,×,○,×,定期，
B店・・・・・伊藤,×,○,×,○,×,○,××，
・
AA店・・・・伊藤,○,×,×,○,×,○,隔週

上記のうち、担当：伊藤の月曜に○の入った箇所のみをシートに抽出するという形になります。

説明不足で大変申し訳ありません。

回答No.1

n-jun

>同ブックのシートでも
担当・曜日別にシート作成ですか？
それとも、担当者別？

補足

担当別です。
さらに細かい説明をすると、
例
Sheet1　データ一覧
Sheet2　担当Aの月曜
Sheet3　担当Aの火曜
・
・
Sheet16　担当Dの土曜

という感じで転記できればBESTです。
説明不足で申し訳ありません。