[[20130108190942]]　『重複をチェックしてメッセージボックスに表示』（ゆき）　ページの最後に飛ぶ

『重複をチェックしてメッセージボックスに表示』（ゆき）

 Excelで受注リストの管理をしています。

 B列に「管理番号」という文字列がありますが、この番号が重複しているかどうかを1日の終わりにチェックしようとしています。

 シートは下記のようになっています。

 　　　A　　　　B　　　　　C　　　・・・・
 1　　1月度受注リスト
 2
 3　 日付　　管理番号　　物件
 4　 1/8　　AA1212-01　東京商事
 5　 1/8　　AB1212-01　大阪商店
 6　 1/9　　AA1212-02　福岡商会
 7　 1/10　 BB1212-01　東京商事

 このリストで、シート上にボタンを設置し、ボタンクリックでB列にまったく同じ番号（文字列）があった場合に

 「　　下記の管理番号が重複しています
 　　　AA1212-10
 　　　AB1212-20　　　　　　　　　　　」

 というようなメッセージボックスを表示させたいのですが、同時に複数の管理番号を表示させる方法がわかりません。

 今書いているコードは下記のようなものです。

 Option Explicit

 Sub 重複チェック()

 Dim i As Long
 Dim j As Long
 Dim z As Long
 Dim Kanri As String
 Dim cnt As Long

 cnt = 0

 With Sheets("受注リスト")

    z = .Cells(Rows.Count, 1).End(xlUp).Row

    For i = 4 To z
        For j = i + 1 To z

            If .Cells(i, 2).Value = .Cells(j, 2).Value Then
                Kanri = .Cells(i, 2).Value
                cnt = cnt + 1

                MsgBox "下記の管理番号が重複しています" & vbCrLf & Kanri

                Exit For
            End If
        Next j
    Next i

    If cnt = 0 Then

        MsgBox "重複している管理番号はありません"
        Exit Sub
    End If
 End With

 End Sub

 上記のコードでは、複数の重複管理番号があった場合に1つのメッセージボックスにつき
 1つの管理番号しか表示できず、いくつもメッセージボックスが表示されたりします。

 重複した管理番号が複数ある時にまとめて一つのメッセージボックスに表示させるにはどうしたらよいでしょうか。

 管理番号の表示の仕方は

 「　　下記の管理番号が重複しています
 　　　AA1212-10,AB1212-20　　　　　」

 このように横に並べても構いません。

 Excel2010です。
 よろしくお願いします。

 都度メッセージを表示するのではなく、検出時はメッセージを作成し
 確認終了後に表示するようにすればどうでしょうか。

 確認方法も Dictionary を使う方法にした例ですが、ご参考まで。
 (Mook)

 Option Explicit
 Sub 重複チェック()

    Dim objDic As Object
    Set objDic = CreateObject("Scripting.Dictionary")

    Dim msg As String
    msg = ""

    Dim i As Long
    Dim z As Long
    With Sheets("受注リスト")
        z = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 4 To z
            If objDic.Exists(.Cells(i, 2).Value) = True Then
                msg = msg & vbNewLine & .Cells(i, 2).Value
            Else
                objDic(.Cells(i, 2).Value) = True
            End If
        Next i

        If msg <> "" Then
            MsgBox "下記の管理番号が重複しています" & msg
        Else
            MsgBox "重複している管理番号はありません"
        End If
    End With
 End Sub

 アップ後、よく見たら、Mookさんのと重なっているところが多かった。
 まぁ、バリエーションとして。

 なお、、（ゆき）さんの二重ループの構成、データ数が少なければ問題はないけど
 データ数が多くなれば結構時間がかかるね。この形で処理するなら、事前に並び替えを
 行って、二重ループをなくすことも検討してみたらいいと思う。

 Sub 重複チェック2()

    Dim c As Range
    Dim dicA As Object
    Dim dicB As Object

    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")

    With Sheets("受注リスト")

        For Each c In .Range("B4", .Range("B" & .Rows.Count).End(xlUp))
            If dicA.exists(c.Value) Then dicB(c.Value) = True
            dicA(c.Value) = True
        Next

    End With

    If dicB.Count = 0 Then
        MsgBox "重複している管理番号はありません"
    Else
        MsgBox "下記の管理番号が重複しています" & vbCrLf & Join(dicB.keys, vbLf)
    End If

 End Sub

 (ぶらっと)

 もうひとつバリエーション。(ROUGE)
　
Sub Sample()
Dim tbl, i As Long, x, ky, txt As String
With Sheets("受注リスト")
    tbl = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3).Value
End With
With CreateObject("Scripting.Dictionary")
    For i = 4 To UBound(tbl, 1)
        If .Exists(tbl(i, 2)) Then
            x = .Item(tbl(i, 2))
            x(0) = True
            x(1) = x(1) & ", " & i
            .Item(tbl(i, 2)) = x
        Else
            .Add tbl(i, 2), Array(False, i)
        End If
    Next
    For Each ky In .Keys
        If .Item(ky)(0) Then
            txt = txt & vbCrLf & ky & "   : " & .Item(ky)(1) & " 行目"
        End If
    Next
    If Len(txt) Then
        MsgBox "下記の管理番号が重複しています" & txt
    Else
        MsgBox "重複している管理番号はありません"
    End If
End With
End Sub

 Loop無しで、

 Option Explicit

 Sub test()
     Dim x As String, y
     With Range("b4", Range("b" & Rows.Count).End(xlUp))
         x = .Address(0, 0)
         y = Filter(Evaluate("transpose(index(if(countif(offset(" & x & _
         ",0,0,row(1:" & .Rows.Count & "))," & x & ")=2," & x & ",""zzz""),))"), "zzz", 0)
         If UBound(y) > -1 Then
             MsgBox vbTab & "下記の管理番号が重複しています" & _
             vbTab & String(2, vbLf) & vbTab & Join$(y, vbLf & vbTab)
         Else
             MsgBox "重複無し"
         End If
     End With
 End Sub
 (seiya)

 皆様たくさんの案をありがとうございます！

 まだ簡単なマクロしか作れなくて勉強中なので、皆様のコードをよく見て理解できるようになります！

 ※ちなみに、リストは入力した順で並んでいないといけないので、B列を基準にソートはできないんです…
 今のところ「入力順」を示す箇所が無いのが難点なので、リストのレイアウトを考えて入力順に連番を振って、ソートできるような方法も考えてみます。

 （ゆき）

コメント返信：

[ 一覧(最新更新順) ]

[[20130108190942]] 『重複をチェックしてメッセージボックスに表示』（ゆき） ページの最後に飛ぶ

[[20130108190942]]　『重複をチェックしてメッセージボックスに表示』（ゆき）　ページの最後に飛ぶ