シートを複数選択し自動印刷したいのですが、シートの選択過程で重複したシートを排除したいのですがどうしたらよいでしょうか。

質問

Sheet1には以下のようにデータが入力されています。
A列(日付)　B列(顧客コード)　C列(顧客名)　　D列（商品名）
09/09/09　　　1004　　　　　　　上田　　　　　SSS
09/09/09　　　1004　　　　　　　上田　　　　　SSS
09/09/09　　　1005　　　　　　　山田　　　　　AAA
09/09/10　　　1004　　　　　　　上田　　　　　SSS
09/09/10　　　1005　　　　　　　山田　　　　　AAA
09/09/10　　　1006　　　　　　　田中　　　　　BBB
09/09/10　　　1004　　　　　　　上田　　　　　SSS
09/09/10　　　1005　　　　　　　山田　　　　　AAA
Sheet2以降は、顧客コード別に分かれたシート（シート名＝顧客コード）が並んでおり、それぞれ顧客の情報が入力されています。
A列で印刷範囲を指定し（毎日印刷するため、9月10日であれば9月10日の日付分だけ）、B列のコードと同じコード名のシートを印刷するという手順になります。実際は、もっとデータがたくさんありますので手作業ではとても困難になってしまいます。
マクロでやってみようと思い、作成してみたのですが、下記に添付しているマクロでは、Sheet1で同日に同じコードがある場合、シートが重複して印刷されてしまいます。
上記の例で言いますと、9月10日の日付5行を範囲として、B列のコードと同じコード名のシートを検索して印刷するのですが、1004が2つ、1005が2つと、シートが重複してしまいます。
なんとかして、重複するコードは印刷しないという技はないものでしょうか。重複データを消去するという手段は、残念ながら、全て必要なデータですのでそれはできないのです。
マクロ初心者で、応用がなかなか利かないため、どうしても皆さんのお力をお借りしたく、ここへ質問させていただきました。
これからの勉強を兼ねて、ご回答くださる方々の意見を十分に参考にさせていただきたいと思っておもりますので、どうぞよろしくお願いいたします。
Sub test1()

Dim n As Long
Dim R1 As Long, R2 As Long
Dim i As Long
Dim myRange As Range

R1 = ActiveCell.Row
R2 = R1 + Selection.Rows.Count - 1

For i = R1 To R2
Set myRange = Worksheets(CStr(Cells(i, 3).Value)).Range("P:AD")
myRange.PrintOut

Next
End Sub

回答No.1

n-jun · ベストアンサー

一度重複しない顧客コードを取得し、そのデータを基に印刷を行なう。

Sub　try()
　Dim　myDic　As　Object
　Dim　r　As　Range,　rr　As　Range
　Dim　myRange　As　Range
　Dim　myKey　As　Variant

　'　Dictionaryオブジェクトを使います
　Set　myDic　=　CreateObject("Scripting.Dictionary")

　'　選択したセル範囲と同行のＢ列をセット
　Set　rr　=　Intersect(Selection.EntireRow,　Range("B:B"))

　'　----------------------------------
　'　ここで重複する顧客コードはDictionaryでまとめてしまう。
　For　Each　r　In　rr
　　　　　If　LenB(r.Value)　>　0　Then　'　Ｂ列に値があるかどうか
　　　　　　　　myDic(r.Value)　=　Empty
　　　　　End　If
　Next
　'　-----------------------------------

　'　重複のない顧客コードを元に印刷を行なう
　For　Each　myKey　In　myDic.Keys
　　　　　Set　myRange　=　Worksheets(myKey).Range("P:AD")
　　　　　myRange.PrintOut
　Next
　'　-----------------------------------
　Set　myDic　=　Nothing
　Set　rr　=　Nothing
End　Sub

【参考】
Dictionary　オブジェクト
http://www.geocities.jp/cbc_vbnet/Scripting/dictionary.html

Excel(エクセル) VBA入門：Dictionaryオブジェクトを利用する
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html

ちょっと書き方は違いますが、ご参考になれば。

補足

ご丁寧にご説明を兼ねてご回答いただき、誠にありがとうございます。
一度、テストさせていただきました。Dictionaryオブジェクトは初心者の私にとって初めて使用するものですので、頑張って理解しながら読ませていただきました。
Set myRange = Worksheets(myKey).Range("P:AD")
の部分でエラーになってしまいます。Dictionaryオブジェクトの理解がまだ乏しいせいか、なぜエラーになってしまうのかが、大変申し訳ないのですが、わからないのです。頼りっきりで申し訳ないですが、よろしくお願いいたします。

回答No.5

n-jun

＃４です。

Ｂ列であっているのなら
＞Set myRange = Worksheets(myKey).Range("P:AD")
Set myRange = Worksheets(Cstr(myKey)).Range("P:AD")
です。

お礼

説明文ではB列で、マクロコードはC列になっておりまして、ややこしくすみませんでした。実際はC列で、必要な部分だけ変えてさせていただきました。また新たなマクロを勉強でき、かつ仕事もスムーズにこなせるようになり、とても感謝しています。
ご丁寧かつ迅速にご回答いただき誠にありがとうございました。今回教わりましたマクロも次からは、自分でも使えるようにしていきたいと思っております。

回答No.4

n-jun

＃１です。

＞Set myRange = Worksheets(myKey).Range("P:AD")
＞の部分でエラーになってしまいます。

シート名が
＞B列のコードと同じコード名のシートを印刷するという手順になります。
と言う事から顧客コードで行なってますが、提示されたコードの
＞Set myRange = Worksheets(CStr(Cells(i, 3).Value)).Range("P:AD")
でいくとＣ列（顧客名）なのでしょうか？

もしそうであれば＃１のコードの
＞Set　rr　=　Intersect(Selection.EntireRow,　Range("B:B"))
を
Set　rr　=　Intersect(Selection.EntireRow,　Range("C:C"))
とＣ列に変更して下さい。

お礼

お手数を何度もおかけしてすみませんでした。初心者の知識の乏しさにおつき合いいただきありがとうございます。

回答No.3

n-jun

＃１です。

一応Dictionaryオブジェクトのサンプル（になればいいですが）

Sub　try2()
　Dim　myDic　As　Object
　Dim　myKey　As　Variant
　Dim　st　As　String

　Set　myDic　=　CreateObject("Scripting.Dictionary")

　myDic("みかん")　=　Empty　'　みかん　を追加
　myDic("りんご")　=　Empty　'　りんご　を追加
　myDic("すいか")　=　Empty　'　すいか　を追加

　For　Each　myKey　In　myDic.Keys
　　　　　st　=　st　&　vbLf　&　myKey
　Next

　MsgBox　st

　myDic("みかん")　=　Empty　'　みかん　を追加
　myDic("すいか")　=　Empty　'　すいか　を追加
　myDic("バナナ")　=　Empty　'　バナナ　を追加
　st　=　""

　For　Each　myKey　In　myDic.Keys
　　　　　st　=　st　&　vbLf　&　myKey
　Next

　MsgBox　st
　Set　myDic　=　Nothing
End　Sub

ご参考になれば。

回答No.2

tom11

こんにちは、

試していないので、どうか解りませんが、
以下のコードでどうでしょう。
試してみてください。

Dim shname As New Collection

Sub test1()

Dim n As Long
Dim R1 As Long, R2 As Long
Dim i As Long
Dim myRange As Range

R1 = ActiveCell.Row
R2 = R1 + Selection.Rows.Count - 1

For i = R1 To R2

if check(CStr(Cells(i, 3).Value) then

Set myRange = Worksheets(CStr(Cells(i, 3).Value)).Range("P:AD")
myRange.PrintOut

end if

Next
End Sub

Public Function check(sh As String) As Boolean

Dim i As Integer

For i = 1 To shname.Count

If shname.Item(i) = sh Then

check = False
Exit Function

End If

Next

shname.Add sh
check = True

End Function

お礼

ご丁寧に、かつ迅速なご回答ありがとうございました。また違ったマクロの組方として、とても勉強になりました。今回ご教授いただいた事も含め、今後さらに勉強を重ねていきたいと思っております。ありがとうございました。