loop処理について

質問

こんにちは。
VISUAL BASIC初心者のため、思う様に動作せず困っています。
参考書を真似て以下の様なマクロを記述しました。

　 Sheets(Array("商品台帳")).Select
Set DupList = CreateObject("Scripting.Dictionary")
Set base = Range("A2")
i = 0
Do While (base.Offset(i).Value <> "")
Set x = base.Offset(i)
If DupList.Exists(x.Value) Then
DupList.Item(x.Value) = DupList.Item(x.Value) & "," & x.Row
Else
DupList.Add x.Value, x.Row
End If
i = i + 1
Loop
For Each i In DupList.keys
If InStr(DupList.Item(i), ",") > 0 Then
MsgBox i & "が、" & StrConv(DupList.Item(i), vbWide) & "行目で重複しています。" & Chr(13) _
& "重複行を修正し、初期化からやり直してください。 ", , "商品コード重複！"
End If
Next
Sheets("メニュー").Select
End Sub

やりたいことは、商品台帳シートの商品コード欄に
重複があれば、重複している組数だけメッセージボックスで知らせて、
重複がなければ、なにも出さずにメニューシートに移りたいのです。
今のコードから変更したいのは、
重複している場合は商品台帳シートのまま、
重複していない場合はメニューシートに移動するという点です。

どうもLOOPの使い方を理解できていない様で、いろいろ修正を試してみたのですが、
重複コードが複数組あるのに1組のメッセージだけしか表示されなくなってしまったりして上手く修正出来ません。

どの様に修正すれば良いのか教えて頂けませんか？

回答No.3

zap35 · ベストアンサー

＃０２です。後半部を「重複」シートに書き込むようにしてみました。
エラーがある/ないを判定するFor～Nextと、エラーを書き出すFor～Nextの２回繰り返し処理を行います。（「重複」シートは予め存在するものとします）

Dim psw As Boolean
Dim idx As Integer
　For Each i In DupList.Keys
　　If InStr(DupList.Item(i), ",") > 0 Then
　　　psw = True
　　End If
　Next
　Sheets("重複").Cells.ClearContents
　If psw Then
　　idx = 2
　　With Sheets("重複")
　　　.Range("A1").Value = "商品コード"
　　　.Range("B1").Value = "出現する行番号"
　　　For Each i In DupList.Keys
　　　　If InStr(DupList.Item(i), ",") > 0 Then
　　　　　.Cells(idx, 1).Value = i
　　　　　.Cells(idx, 2).Value = mydir(i)
　　　　　idx = idx + 1
　　　　End If
　　　Next
　　End With
　End If

お礼

お礼が遅くなり申し訳ありません。
zap35様、いつもご丁寧な回答ありがとうございます。
すごく参考になります。
重複するコードを重複シートに書き込めるのですね。
なるほど!!!!
すごく難しいコードが必要かと思っていましたが、
それ程複雑なコードを書かなくても可能なのですね。
絶対こちらの方が便利だと思います。
感激しました。是非試してみます。
ありがとうございます。

回答No.4

Wendy02

こんばんは。

ずいぶん、凝った作り方をされているようですが、もし、重複行をピックアップするなら、CountIf を使えばよいと思うのです。

関数なら、以下のようにして、ずっと、ドラッグでコピーします。

=IF(COUNTIF($A$2:A13,A13)>1,"○","")

マクロなら、以下のようにします。

　Dim i As Long
　With Worksheets("商品台帳")
　.Select
　Application.ScreenUpdating = False
　　For i = 2 To .Range("A65536").End(xlUp).Row
　　　If WorksheetFunction.CountIf(.Range("A2", .Cells(i, 1)), .Cells(i, 1).Value) > 1 Then
　　　　 .Cells(i, 4).Value = "○"　　'適当な場所に○を出す。
　　　End If
　　Next i
　　Application.ScreenUpdating = True
　End With

でも、修正して、一意のデータにしてしまうのなら、最初から、AdvancedFilter を使ってしまえばよいと思います。

With Worksheets("商品台帳")

　.Range("A1", .Range("A65536").End(xlUp)).AdvancedFilter _
　　 Action:=xlFilterCopy, _
　　 CopyToRange:=.Range("E1"), _
　　 Unique:=True
　.Range("A1", .Range("A65536").End(xlUp)).ClearContents
　.Range("E1", .Range("E65536").End(xlUp)).Copy .Range("A1")
End With

とすればよいと思います。　E1 は適当に、空いた場所の先頭にしてください。

お礼

お礼が遅くなり申し訳ありません。
ご回答ありがとうございます。

＞ずいぶん、凝った作り方をされているようですが、
やりたいことをネットで検索したら、今の様な方法が紹介されていたもので、そのままアレンジしたらこうなってしまったのです。
そうですか・・・凝った作りなんですね。

＞重複行をピックアップするなら、
＞CountIf を使えばよいと思うのです。
なるほど、確かに私にはこちら方法の方が何をしているかは分かりやすいです。

＞でも、修正して、一意のデータにしてしまうのなら、
＞最初から、AdvancedFilter を使ってしまえばよいと思います。
AdvancedFilter・・・初めて知りました。
ネットで調べてみたら、いろいろ検索できました。
そんな方法があるのですね。
恥ずかしながら、まだ良く使い方が理解できておりませんが、
今後、じっくり勉強したいと思います。
また、宜しくお願いします。
ありがとうございました。

回答No.2

zap35

＞重複があれば、重複している組数だけメッセージボックスで知らせて、
＞重複がなければ、なにも出さずにメニューシートに移りたいのです。
だけを考えれば、後半部を以下のようなロジックにすれば良いのではないでしょうか。

なお変数はきちんと型を定義する方がよいです。特にこのマクロのように変数「i」を異なる型で繰り返し使うようなコーディングスタイルだと、もっと長いマクロになると誤動作の元になります。

Dim psw As Boolean　'追加
For Each i In DupList.keys
　If InStr(DupList.Item(i), ",") > 0 Then
　　MsgBox i & "が、" & StrConv(DupList.Item(i), vbWide) & "行目で重複しています。" & Chr(13) _
　　　& "重複行を修正し、初期化からやり直してください。 ", , "商品コード重複！"
　　psw = True　'追加
　End If
Next
If psw = False Then　'追加
　Sheets("メニュー").Activate　'追加
End If 　'追加
' Sheets("メニュー").Select　この行は削除

また、重複する商品が多数ある時、Msgboxで次々にメッセージを表示してもどの行がエラーだったか全ては覚えていられないでしょう。別のシートにチェックした結果を書き出す方が、実運用では便利だと思います

最後にcororon3さんは最近数回お見かけしましたが、回答してもレスポンスはないし、質問も放置したままですね。そのうち回答する人がいなくなりますよ。

お礼

zap35様

最後の2行のご指摘、誠に申し訳ありません。
このサイトの趣旨を良く理解出来ていなかった様です。
数回に渡り大変親切にご回答下さったのに、私がご回答頂いた内容を十分理解できるレベルでなく、ご不快な思いをお掛けしました。

ご回答頂いた内容について
＞また、重複する商品が多数ある時、Msgboxで次々にメッセージを表示しても
＞どの行がエラーだったか全ては覚えていられないでしょう。
＞別のシートにチェックした結果を書き出す方が、実運用では便利だと思います

まったくご指摘の通りです。
今後実際に使って見て、どの程度の重複行が発生するかを観察しながら、そうした方法に切り替えなければならないと思っています。
ただ、何分私のレベルがそうは思ってもスラスラと修正できるまでに至っていないもので、少しずつ勉強しながらやっていこうと思っています。
ご回答、ありがとうございました。

回答No.1

kigoshi

Dim exFlg as Boolean
Sheets(Array("商品台帳")).Select

※省略

i = i + 1
Loop
exFlg=True
For Each i In DupList.keys
If InStr(DupList.Item(i), ",") > 0 Then
MsgBox i & "が、" & StrConv(DupList.Item(i), vbWide) & "行目で重複しています。 " & Chr(13) _
& "重複行を修正し、初期化からやり直してください。 ", , "商品コード重複！"
exFlg=False
End If
Next
If exFlg then
Sheets("メニュー").Select
End If
End Sub

ではいかがでしょうか。

お礼

この通りの方法を試してみたら思い通りにできました。
ありがとうございました。
フラグを立てて、それぞれの場合分けの処理を展開しているのですね。
なるほど分かりやすいですね。
記述されたのを見ると納得するのですが、自分で組むとなると難しいです。
もっと勉強します。ありがとうございました。