あなたは何にトキメキますか?

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

A 回答 (5件)

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



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")

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

 ' ----------------------------------
 ' ここで重複する顧客コードはDictionaryでまとめてしまう。
 For Each r In rr
     If LenB(r.Value) > 0 Then ' B列に値があるかどうか
        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/dict …

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

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

この回答への補足

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

補足日時:2009/09/10 14:32
    • good
    • 0

#4です。



B列であっているのなら
>Set myRange = Worksheets(myKey).Range("P:AD")
Set myRange = Worksheets(Cstr(myKey)).Range("P:AD")
です。
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/09/10 17:09

#1です。



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

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

もしそうであれば#1のコードの
>Set rr = Intersect(Selection.EntireRow, Range("B:B"))

Set rr = Intersect(Selection.EntireRow, Range("C:C"))
とC列に変更して下さい。
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/09/10 17:11

#1です。



一応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

ご参考になれば。
    • good
    • 0

こんにちは、



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

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
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/09/10 17:14

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


おすすめ情報