取出不同设备号的不重复的编号

如云家家

请帮看一下怎么样可以在汇总表中只取出每个设备号的不重复的编号,每一个工作表是一台设备,只是B列的编号有重复的.谢谢帮帮助.

liulang0808

去重的案例论坛很多，字典为主吧，楼主先搜索下

Excel__Boy

1. Sub Excel手把手()
   
2. Dim n As Byte
   
3. Dim arr
   
4. Dim d
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Dim i As Long
   
7. For n = 2 To Worksheets.Count
   
8.     arr = Worksheets(n).UsedRange
   
9.     For i = 2 To UBound(arr)
   
10.         d(arr(i, 1) & "÷" & arr(i, 2)) = ""
    
11.     Next i
    
12. Next n
    
13. With Worksheets("汇总")
    
14.     .Range("a2").Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.keys))
    
15.     .Range("A:A").Replace "÷*", ""
    
16.     .Range("B:B").Replace "*÷", ""
    
17.    
    
18. End With
    
19. End Sub
    

复制代码

opel-wong

试试：

opel-wong

上传代码：

1. Sub 遍历工作表取不重复()
   
2.     Dim arr, brr(1 To 4 ^ 8, 1 To 2) As String, i As Long, mSht As Worksheet, mStr As String
   
3.     Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
   
4.     Dim m As Long: m = 0
   
5.     For Each mSht In Worksheets
   
6.         If mSht.Name <> "汇总" Then
   
7.             arr = mSht.UsedRange.Value
   
8.             For i = 2 To UBound(arr)
   
9.                 If Len(arr(i, 1)) > 0 And Len(arr(i, 2)) > 0 Then
   
10.                     mStr = arr(i, 1) & "," & arr(i, 2)
    
11.                     If Not d.Exists(mStr) Then
    
12.                         d(mStr) = ""
    
13.                         m = m + 1
    
14.                         brr(m, 1) = arr(i, 1)
    
15.                         brr(m, 2) = arr(i, 2)
    
16.                     End If
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     With Worksheets("汇总")
    
22.         .Activate
    
23.         .Range("A2:B1048576").ClearContents
    
24.         .Range("A2").Resize(m, 2).Value = brr
    
25.     End With
    
26.     Set d = Nothing
    
27. End Sub
    

复制代码

chis3

opel-wong 发表于 2020-3-6 16:39
试试：

請問這是什麼編輯器?

opel-wong

chis3 发表于 2020-3-6 16:45
請問這是什麼編輯器?

就是这个了，sublime

一指禅62

对楼主要求理解得没把握，猜猜看

1. Sub 汇总()
   
2.     Dim d As Object, Sh As Worksheet, arr, a(), i&, n%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     For Each Sh In Worksheets
   
5.         If Sh.Name <> "汇总" Then
   
6.             arr = Sh.Range("A1").CurrentRegion
   
7.             For i = 2 To UBound(arr)
   
8.                 If Trim(arr(i, 2)) <> "" Then
   
9.                     d(Trim(arr(i, 1)) & "|" & Trim(arr(i, 2))) = arr(i, 1)
   
10. '                    d(Trim(arr(i, 2))) = arr(i, 1)
    
11.                 End If
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     Sheet1.Range("A2:B10000").ClearContents
    
16.     If d.Count > 0 Then
    
17.         Sheet1.Range("A2").Resize(d.Count, 2) = _
    
18.             WorksheetFunction.Transpose(Array(d.items, d.keys))
    
19.         Sheet1.Range("B:B").Replace "*|", ""
    
20.     End If
    
21. End Sub

复制代码

网海遨游

是不是这样的?