多列去重输入到另外一列 求助代码

jany1312

我是VBA菜鸟，只知道单列去重可以用高级筛选，copy等方法，但是多列就不知道怎么做了，求助大神

sheeboard

这个不是去重，是全连接。

jany1312

sheeboard 发表于 2020-10-30 15:17
这个不是去重，是全连接。

那要怎么做，两列里面有重复的内容

奈何丶彼岸

没给你加按钮，直接试试看吧

jany1312

奈何丶彼岸 发表于 2020-10-30 15:48
没给你加按钮，直接试试看吧

非常感谢，我自己加了，就是要这样的

232670631

Sub test()
Dim ar(1 To 1000, 1 To 1)
Dim k, x, i, m, n
For k = 1 To 4 Step 3
x = Cells(100, k).End(3).Row
For i = 3 To x
    m = m + 1
    For n = 1 To UBound(ar)
        If Trim(Cells(i, k)) = ar(n, 1) Then
            m = m - 1: GoTo 100
        End If
    Next
        ar(m, 1) = Trim(Cells(i, k))
100: Next
Next
[g3].Resize(UBound(ar), 1) = ar
End Sub

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     For j = 1 To 4 Step 3
   
8.       r = .Cells(.Rows.Count, j).End(xlUp).Row
   
9.       arr = .Cells(3, j).Resize(r - 2, 2)
   
10.       n = Int(j / 4) + 2
    
11.       For i = 1 To UBound(arr)
    
12.         If Not d.exists(arr(i, 1)) Then
    
13.           ReDim brr(1 To 3)
    
14.           brr(1) = arr(i, 1)
    
15.         Else
    
16.           brr = d(arr(i, 1))
    
17.         End If
    
18.         brr(n) = arr(i, 2)
    
19.         d(arr(i, 1)) = brr
    
20.       Next
    
21.     Next
    
22.     .Range("g3").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
    
23.   End With
    
24. End Sub
    

复制代码

chxw68

详见附件。

renkangjizhen

Sub ttt()
Dim x%, y%, d, m%
Set d = CreateObject("scripting.dictionary")
For y = 1 To 4 Step 3
    For x = 3 To Cells(2, y).End(xlDown).Row
        If Not d.exists(Cells(x, y).Value & Cells(2, y + 1).Value) Then
         d(Cells(x, y).Value & Cells(2, y + 1).Value) = Cells(x, y + 1)
        End If
Next
Next
For m = 3 To [g3].End(xlDown).Row
Cells(m, "h") = d(Cells(m, "g").Value & Cells(2, "h").Value)
Cells(m, "i") = d(Cells(m, "g").Value & Cells(2, "i").Value)
Next
Set d = Nothing
End Sub

renkangjizhen

代码在附件中