[已解决]VBA用两种方法多行多列去重

laoau138

VBA用两种方法多行多列去重

最佳答案

月排行榜 / 总排行榜

sarah_zxx

2017-11-1 21:32

1. <div class="blockcode"><blockquote>Sub arrff()
   
2.     Dim rg As Range, irows As Integer, str As String, brr
   
3.     irows = Worksheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row
   
4.     For Each rg In Worksheets("sheet1").Range("a1:c" & irows)
   
5.         If rg = "" Then GoTo 100
   
6.         If InStr(1, str, Trim(rg.Value)) = 0 Then
   
7.             str = str & "#" & VBA.Trim(rg.Value)
   
8.         End If
   
9. 
   
10. 100:
    
11.     Next
    
12.     Worksheets("sheet1").Columns("E:E").ClearContents
    
13.     brr = VBA.Split(Right(str, Len(str) - 1), "#")
    
14.     Worksheets("sheet1").Range("e1").Resize(UBound(brr) + 1) = Application.Transpose(brr)
    
15.    
    
16. End Sub
    

复制代码

跳转到最佳答案楼层

fjmxwrs

第一个参数，使用绝对引用

1. Function Replacetwo(Rng1 As Range, n)
   
2.     Dim arr, brr, i&, x%, y%, w%
   
3.     Dim d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Rng1.Value
   
6.     w = n - 1
   
7.     For x = 1 To UBound(arr)
   
8.         For y = 1 To UBound(arr, 2)
   
9.             If Not d.exists(arr(x, y)) Then
   
10.                 i = i + 1
    
11.                 d(arr(x, y)) = i
    
12.             End If
    
13.         Next y
    
14.     Next x
    
15.     brr = d.keys
    
16.     If w >= d.Count Then
    
17.         Replacetwo = ""
    
18.     Else
    
19.         Replacetwo = brr(w)
    
20.     End If
    
21.     d.RemoveAll
    
22.     Erase arr, brr
    
23. End Function

复制代码

laoau138

fjmxwrs 发表于 2017-10-29 20:38
第一个参数，使用绝对引用

还有数组方法没有写

laoau138

还有数组方法没有写

sarah_zxx

1. Sub dicff()
   
2. Dim rg As Range, irows As Integer, dic As Object
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     irows = Worksheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row
   
5.     For Each rg In Worksheets("sheet1").Range("a1:c" & irows)
   
6.         If rg = "" Then GoTo 100
   
7.         dic(rg.Value) = ""
   
8. 100:
   
9.     Next
   
10.     Worksheets("sheet1").Columns("E:E").ClearContents
    
11.     Worksheets("sheet1").Range("e1").Resize(dic.Count) = Application.Transpose(dic.keys)
    
12.    
    
13. End Sub

复制代码

laoau138

sarah_zxx 发表于 2017-11-1 11:34

用数组方法，不要用字典方法，VBA高手

sarah_zxx

1、字典方法 2、数组方法

sarah_zxx

1. <div class="blockcode"><blockquote>Sub arrff()
   
2.     Dim rg As Range, irows As Integer, str As String, brr
   
3.     irows = Worksheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row
   
4.     For Each rg In Worksheets("sheet1").Range("a1:c" & irows)
   
5.         If rg = "" Then GoTo 100
   
6.         If InStr(1, str, Trim(rg.Value)) = 0 Then
   
7.             str = str & "#" & VBA.Trim(rg.Value)
   
8.         End If
   
9. 
   
10. 100:
    
11.     Next
    
12.     Worksheets("sheet1").Columns("E:E").ClearContents
    
13.     brr = VBA.Split(Right(str, Len(str) - 1), "#")
    
14.     Worksheets("sheet1").Range("e1").Resize(UBound(brr) + 1) = Application.Transpose(brr)
    
15.    
    
16. End Sub
    

复制代码

laoau138

sarah_zxx 发表于 2017-11-1 21:32

果然是高手

laoau138

sarah_zxx 发表于 2017-11-1 21:32

高手如何做下面几条


VBA只能用数组方法改写   按B列地址拆分工作表  里面有代码


http://www.excelpx.com/thread-434686-1-1.html



VBA用两种方法改写跨表比较 里面有代码

http://www.excelpx.com/thread-434658-1-1.html


用VBA数组第二种方法填充绿色


http://www.excelpx.com/thread-434739-1-1.html