[已解决]两列重复值

lidayu

恳请老师赐教，如何统计两列中出现重复值的数量及位置，详见附件
两列同样数值重复.rar (7.5 KB, 下载次数: 12)

2016-6-18 14:12 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-18 16:50

lidayu 发表于 2016-6-18 16:34
老司机带带我 您好，就是要这样效果。我突然想能不能把P、Q列并在P列用（数量-行号），烦请您再帮我改下 ...

1. Sub xx()
   
2.     Dim d, i&, j&, n&, arr, brr(), x&, crr, temp&, drr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         n = .Cells(.Rows.Count, 8).End(xlUp).Row
   
6.         arr = .Range("H4:J" & n)
   
7.         For i = 1 To n - 3
   
8.             'ReDim Preserve brr(1 To 2, 1 To i)
   
9.             If arr(i, 1) < arr(i, 2) Then
   
10.                 temp = arr(i, 1)
    
11.                 arr(i, 1) = arr(i, 2)
    
12.                 arr(i, 2) = temp
    
13.             End If
    
14.             If Not d.Exists(arr(i, 1) & "_" & arr(i, 2)) Then
    
15.                  d.Add arr(i, 1) & "_" & arr(i, 2), i + 3
    
16.             Else
    
17.                 d(arr(i, 1) & "_" & arr(i, 2)) = d(arr(i, 1) & "_" & arr(i, 2)) & "," & i + 3
    
18.             End If
    
19.         Next
    
20.         For i = 1 To n - 3
    
21.             ReDim Preserve brr(1 To 2, 1 To i)
    
22.              ReDim Preserve drr(1 To i)
    
23.             If InStr(d(arr(i, 1) & "_" & arr(i, 2)), ",") Then
    
24.                 crr = Split(d(arr(i, 1) & "_" & arr(i, 2)), ",")
    
25.                 For j = 0 To UBound(crr)
    
26.                     brr(1, i) = brr(1, i) + arr(crr(j) - 3, 3)
    
27.                 Next
    
28.                 brr(2, i) = d(arr(i, 1) & "_" & arr(i, 2))
    
29.                 d.Remove (arr(i, 1) & "_" & arr(i, 2))
    
30.                 drr(i) = brr(1, i) & "-" & brr(2, 1)
    
31.             End If
    
32.         Next
    
33.         .Range("P4:P" & n) = Application.WorksheetFunction.Transpose(drr)
    
34.     End With
    
35. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

1. Sub xx()
   
2.     Dim d, i&, j&, n&, arr, brr(), x&, crr, temp&
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         n = .Cells(.Rows.Count, 8).End(xlUp).Row
   
6.         arr = .Range("H4:J" & n)
   
7.         For i = 1 To n - 3
   
8.             'ReDim Preserve brr(1 To 2, 1 To i)
   
9.             If arr(i, 1) < arr(i, 2) Then
   
10.                 temp = arr(i, 1)
    
11.                 arr(i, 1) = arr(i, 2)
    
12.                 arr(i, 2) = temp
    
13.             End If
    
14.             If Not d.Exists(arr(i, 1) & "_" & arr(i, 2)) Then
    
15.                  d.Add arr(i, 1) & "_" & arr(i, 2), i + 3
    
16.             Else
    
17.                 d(arr(i, 1) & "_" & arr(i, 2)) = d(arr(i, 1) & "_" & arr(i, 2)) & "," & i + 3
    
18.             End If
    
19.         Next
    
20.         For i = 1 To n - 3
    
21.             ReDim Preserve brr(1 To 2, 1 To i)
    
22.             If InStr(d(arr(i, 1) & "_" & arr(i, 2)), ",") Then
    
23.                 crr = Split(d(arr(i, 1) & "_" & arr(i, 2)), ",")
    
24.                 For j = 0 To UBound(crr)
    
25.                     brr(1, i) = brr(1, i) + arr(crr(j) - 3, 3)
    
26.                 Next
    
27.                 brr(2, i) = d(arr(i, 1) & "_" & arr(i, 2))
    
28.                 d.Remove (arr(i, 1) & "_" & arr(i, 2))
    
29.             Else
    
30.                 brr(1, i) = ""
    
31.                 brr(2, i) = ""
    
32.             End If
    
33.         Next
    
34.         .Range("P4:Q" & n) = Application.WorksheetFunction.Transpose(brr)
    
35.     End With
    
36. End Sub

复制代码

lidayu

老司机带带我 发表于 2016-6-18 15:35

老司机带带我 您好，就是要这样效果。我突然想能不能把P、Q列并在P列用（数量-行号），烦请您再帮我改下好吗？谢谢！

老司机带带我

lidayu 发表于 2016-6-18 16:34
老司机带带我 您好，就是要这样效果。我突然想能不能把P、Q列并在P列用（数量-行号），烦请您再帮我改下 ...

1. Sub xx()
   
2.     Dim d, i&, j&, n&, arr, brr(), x&, crr, temp&, drr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         n = .Cells(.Rows.Count, 8).End(xlUp).Row
   
6.         arr = .Range("H4:J" & n)
   
7.         For i = 1 To n - 3
   
8.             'ReDim Preserve brr(1 To 2, 1 To i)
   
9.             If arr(i, 1) < arr(i, 2) Then
   
10.                 temp = arr(i, 1)
    
11.                 arr(i, 1) = arr(i, 2)
    
12.                 arr(i, 2) = temp
    
13.             End If
    
14.             If Not d.Exists(arr(i, 1) & "_" & arr(i, 2)) Then
    
15.                  d.Add arr(i, 1) & "_" & arr(i, 2), i + 3
    
16.             Else
    
17.                 d(arr(i, 1) & "_" & arr(i, 2)) = d(arr(i, 1) & "_" & arr(i, 2)) & "," & i + 3
    
18.             End If
    
19.         Next
    
20.         For i = 1 To n - 3
    
21.             ReDim Preserve brr(1 To 2, 1 To i)
    
22.              ReDim Preserve drr(1 To i)
    
23.             If InStr(d(arr(i, 1) & "_" & arr(i, 2)), ",") Then
    
24.                 crr = Split(d(arr(i, 1) & "_" & arr(i, 2)), ",")
    
25.                 For j = 0 To UBound(crr)
    
26.                     brr(1, i) = brr(1, i) + arr(crr(j) - 3, 3)
    
27.                 Next
    
28.                 brr(2, i) = d(arr(i, 1) & "_" & arr(i, 2))
    
29.                 d.Remove (arr(i, 1) & "_" & arr(i, 2))
    
30.                 drr(i) = brr(1, i) & "-" & brr(2, 1)
    
31.             End If
    
32.         Next
    
33.         .Range("P4:P" & n) = Application.WorksheetFunction.Transpose(drr)
    
34.     End With
    
35. End Sub

复制代码

lidayu

老司机带带我 发表于 2016-6-18 16:50

您好，能不能在出现重复的行或单元格填充颜色，谢谢！