按条件对应列不统一值弹窗提示

yiniuniu

按条件对应列不统一值弹窗提示

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [d1].CurrentRegion
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 2)) Then
            Set d(arr(j, 2)) = CreateObject("scripting.dictionary")
        End If
        d(arr(j, 2))(arr(j, 1)) = ""
    Next j
    str1 = ""
    For Each k In d.keys
        If d(k).Count > 1 Then
            str1 = str1 & Chr(10) & "名称：" & k & " 对应多个所属：" & Join(d(k).keys, ",")
        End If
    Next k
    If Len(str1) > 0 Then MsgBox str1
End Sub

liulang0808

供参考，
也可以根据具体需求修改成表格事件

3190496160

Sub 提示()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    ar = .Range("d1:e" & r)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            If Not dc.exists(ar(i, 1)) Then
                If Not d.exists((ar(i, 2))) Then
                    d(ar(i, 2)) = ar(i, 1)
                Else
                    d(ar(i, 2)) = d(ar(i, 2)) & "," & ar(i, 1)
                End If
                dc(ar(i, 1)) = ""
            End If
        End If
    Next i
End With
For Each k In d.keys
    If InStr(d(k), ",") > 0 Then
        If ts = "" Then
            ts = k & "有不一致信息"
        Else
            ts = ts & Chr(10) & k & "有不一致信息"
        End If
    End If
Next k
If ts = "" Then
    w = "ok!"
Else
    w = ts
End If
Application.ScreenUpdating = True
MsgBox w
End Sub

3190496160

按条件对应列不相同弹窗提示.rar (16.47 KB, 下载次数: 7)

2023-3-8 10:38 上传

点击文件名下载附件

yiniuniu

liulang0808 发表于 2023-3-8 10:28
供参考，
也可以根据具体需求修改成表格事件

求修改现需求

liulang0808

按条件对应列不相同弹窗提示.zip (18.81 KB, 下载次数: 5)

2023-3-10 12:18 上传

点击文件名下载附件

模拟供参考

yiniuniu

liulang0808 发表于 2023-3-10 12:18
模拟供参考

帮忙改成按钮不要事件的

liulang0808

熊文来

liulang0808 发表于 2023-3-8 10:27
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [d1].CurrentRegion

应该可以用一用，方便。