[已解决]查询相同的问题

小玲玲

附件 查询相同.rar (6.34 KB, 下载次数: 11)

2014-6-24 15:16 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

fffox

2014-6-24 15:57

请测试：

1. Sub test()
   
2.     Dim arr, brr(1 To 500, 1 To 1), dic As Object
   
3.     Dim i%, j%, k%, x As Boolean
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheets(1).[a1].CurrentRegion.Value
   
6.     For i = 1 To UBound(arr) - 2
   
7.         If Not dic.exists(arr(i, 1)) Then
   
8.             dic(arr(i, 1)) = ""
   
9.             x = False
   
10.             For j = i + 1 To UBound(arr) - 1
    
11.                 If arr(i, 1) = arr(j, 1) Then
    
12.                     k = k + 1
    
13.                     If x = False Then
    
14.                         brr(3 * (k - 1) + 1, 1) = arr(i, 1)
    
15.                         brr(3 * (k - 1) + 2, 1) = arr(i + 1, 1)
    
16.                         k = k + 1
    
17.                         x = True
    
18.                     End If
    
19.                     brr(3 * (k - 1) + 1, 1) = arr(j, 1)
    
20.                     brr(3 * (k - 1) + 2, 1) = arr(j + 1, 1)
    
21.                 End If
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     Sheets(1).[c1].Resize(3 * k) = brr
    
26. End Sub
    

复制代码

跳转到最佳答案楼层

fffox

请测试：

1. Sub test()
   
2.     Dim arr, brr(1 To 500, 1 To 1), dic As Object
   
3.     Dim i%, j%, k%, x As Boolean
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheets(1).[a1].CurrentRegion.Value
   
6.     For i = 1 To UBound(arr) - 2
   
7.         If Not dic.exists(arr(i, 1)) Then
   
8.             dic(arr(i, 1)) = ""
   
9.             x = False
   
10.             For j = i + 1 To UBound(arr) - 1
    
11.                 If arr(i, 1) = arr(j, 1) Then
    
12.                     k = k + 1
    
13.                     If x = False Then
    
14.                         brr(3 * (k - 1) + 1, 1) = arr(i, 1)
    
15.                         brr(3 * (k - 1) + 2, 1) = arr(i + 1, 1)
    
16.                         k = k + 1
    
17.                         x = True
    
18.                     End If
    
19.                     brr(3 * (k - 1) + 1, 1) = arr(j, 1)
    
20.                     brr(3 * (k - 1) + 2, 1) = arr(j + 1, 1)
    
21.                 End If
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     Sheets(1).[c1].Resize(3 * k) = brr
    
26. End Sub
    

复制代码

cbg2008

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim strItems
   
4.     Dim i As Long
   
5.     Dim j As Long
   
6.     Dim k As Long
   
7.     Dim arrOutput(1 To 300)
   
8.     Dim arrSource
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     arrSource = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
    
11.     For i = 1 To UBound(arrSource)
    
12.         d(arrSource(i, 1)) = d(arrSource(i, 1)) & "," & i
    
13.     Next
    
14.     strItems = d.items
    
15.     k = -2
    
16.     For i = 0 To UBound(strItems)
    
17. 
    
18.         If UBound(Split(strItems(i), ",")) > 1 Then
    
19.             For j = 1 To UBound(Split(strItems(i), ","))
    
20.                 k = k + 3
    
21.                 arrOutput(k) = arrSource(Split(strItems(i), ",")(j), 1)
    
22.                 arrOutput(k + 1) = arrSource(Split(strItems(i), ",")(j) + 1, 1)
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     Columns("C").ClearContents
    
27.     If k > 0 Then
    
28.         Range("C1").Resize(k + 1, 1) = WorksheetFunction.Transpose(arrOutput)
    
29.     Else
    
30.         Range("C1") = "没有重复数据"
    
31.     End If
    
32. End Sub

复制代码