查询重复项

yangwen12182814

多条件查询，要求在附件中！烦请各位老师解决下！谢谢

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, r&, dic As Object, strJoin$, vKey
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    For i = 3 To UBound(ar)
        strJoin = ""
        For j = 2 To 5
            strJoin = strJoin & "," & ar(i, j)
        Next j
        dic(strJoin) = dic(strJoin) & " " & i
    Next i
   
    r = 2
    For Each vKey In dic.keys
        br = Split(dic(vKey))
        If UBound(br) > 2 Then
            For i = 1 To UBound(br)
                r = r + 1
                For j = 1 To UBound(ar, 2)
                    ar(r, j) = ar(br(i), j)
                Next j
            Next i
        End If
    Next
   
    [A1].CurrentRegion.Offset(2).Clear
    [A1].Resize(r, 7) = ar
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

记录中无重复，数据请自行验证。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.1
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("维修记录").UsedRange
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.     For i = 3 To UBound(arr)
   
8.         S = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
   
9.         d(S) = d(S) + 1
   
10.     Next
    
11.     For i = 3 To UBound(arr)
    
12.         S = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
    
13.         t = d(S)
    
14.         If t > 1 Then
    
15.             m = m + 1
    
16.             For j = 1 To UBound(arr, 2)
    
17.                 brr(m, j) = arr(i, j)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With Sheets("结果")
    
22.         .UsedRange.Offset(2) = ""
    
23.         If m > 0 Then
    
24.             .Range("a3").Resize(m, UBound(arr, 2)) = brr
    
25.             .Range("a3").Resize(m, UBound(arr, 2)).Borders.LineStyle = 1
    
26.         Else
    
27.             MsgBox "无重复记录！"
    
28.         End If
    
29.     End With
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码

quqiyuan

参与一下，供参考。。。。

quqiyuan

代码如下。。。
Sub 按钮1_Click()
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("维修记录")
    Set sh = wb.Sheets("结果")
    Set d = CreateObject("scripting.dictionary")
    arr = sht.Range("a3:g" & sht.Cells(Rows.Count, 1).End(3).Row)
    ReDim brr(1 To 10000, 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        s = Empty
        For j = 2 To 5
            s = s & "|" & arr(i, j)
        Next
        If Not d.exists(s) Then
            d(s) = 1
        Else
            If d(s) = 1 Then
                n = n + 1
                For j = 1 To UBound(arr, 2)
                    brr(n, j) = arr(i, j)
                Next
                d(s) = 2
            End If
        End If
    Next
    sh.[a3].Resize(10000, UBound(arr, 2)).ClearContents
    If n <> Empty Then sh.[a3].Resize(n, UBound(arr, 2)) = brr
    Set d = Nothing
    Beep
End Sub

yangwen12182814

ykcbf1100 发表于 2024-8-1 19:40
附件供参考。。。

非常感谢，老师的解答！