求用VBA实现数据整理，剔除每行数据中的重复值

wuyang2019

A-k列是数据原始样子，m-s列的VBA程序整理后样子
A-k列中每行都会有重复值，希望通过整理，将重复值剔除，重新粘贴在行对应的m-s列中

提示：1、整理后的行长度不是固定的，长度取决于a-k列剔除重复值后的数据长度
2、数据量很大，请考虑运行速度
感谢各位老师的相助，先谢谢了

wuyang2019

求助求助帮帮忙

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     r = ActiveSheet.UsedRange.Rows.Count
   
4.     arr = [a2].Resize(r, 11)
   
5.     Application.ScreenUpdating = False
   
6.     With CreateObject("vbscript.regexp")
   
7.         .Global = True
   
8.         .Pattern = "\d+"
   
9.         For j = 2 To UBound(arr)
   
10.             d.RemoveAll
    
11.             For i = 1 To UBound(arr, 2)
    
12.                 For Each mh In .Execute(arr(j, i))
    
13.                     If Len(mh) > 0 Then d(mh.Value) = ""
    
14.                 Next mh
    
15.             Next i
    
16.             If d.Count > 0 Then
    
17.                 Cells(j + 1, "m").Resize(1, d.Count) = d.keys
    
18.             End If
    
19.         Next j
    
20.     End With
    
21.     Appli

复制代码

liulang0808

附件内容供参考。。。。。。

Jason_WangSS

1. Sub test()
   
2.     Dim arr, d As Object
   
3.     Dim i%, j%, x%
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     arr = Range("a3", Cells([a3].End(xlDown).Row, "K"))
   
6.    
   
7.     For i = 1 To UBound(arr, 1)
   
8.         brr = Join(WorksheetFunction.Index(arr, i, 0), ",")
   
9.         Do While InStr(brr, "")
   
10.             brr = Replace(brr, "", ",")
    
11.         Loop
    
12.         brr = Replace(brr, " ", ",")
    
13.         crr = Split(brr, ",")
    
14.         For j = 0 To UBound(crr)
    
15.             d(crr(j)) = crr(j)
    
16.         Next
    
17.         If d.exists("") Then d.Remove ("")
    
18.         Worksheets(1).Range("m10")(n + 1, 1).Resize(1, d.Count) = d.keys
    
19.         n = n + 1
    
20.         Set brr = Nothing
    
21.         d.RemoveAll
    
22.     Next
    
23. End Sub

复制代码

astupig

1. Sub Test()
   
2.     Dim arr, d, i, j, t
   
3.     arr = Range("A1:K5")
   
4.    
   
5.     For i = 3 To UBound(arr)
   
6.         Set d = CreateObject("Scripting.Dictionary")
   
7.         For j = 1 To UBound(arr, 2)
   
8.             For t = 0 To UBound(Split(arr(i, j), ""))
   
9.                 myKey = Split(arr(i, j), "")(t)
   
10.                 If (Not d.exists(myKey)) And myKey <> "" Then d(myKey) = ""
    
11.             Next t
    
12.         Next j
    
13.         Range("M" & i).Resize(1, d.Count) = d.keys
    
14.     Next i
    
15. End Sub

复制代码

deadzlq

PQ参考解法