提取带空行多列不重复值

qing0408

请老师帮忙做提取带空行多列不重复值的vba。用函数慢到发指。谢谢！

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.     r = .Columns("k:r").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
8.     arr = .Range("k3:r" & r)
   
9.     For j = 1 To UBound(arr, 2)
   
10.       For i = 1 To UBound(arr)
    
11.         If Len(arr(i, j)) <> 0 Then
    
12.           d(arr(i, j)) = ""
    
13.         End If
    
14.       Next
    
15.     Next
    
16.     .Range("a2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
17.   End With
    
18. End Sub
    

复制代码

chxw68

字典的基本应用。

qing0408

chxw68 发表于 2019-3-11 11:06
字典的基本应用。

字典太强大了。表示感谢。

qing0408

chxw68 发表于 2019-3-11 11:06
字典的基本应用。

   r = .Columns("k:r").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    arr = .Range("k3:r" & r)

请教老师，如果是需要K列，m列，o列，q列，该怎样改

chxw68

qing0408 发表于 2019-3-11 11:19
r = .Columns("k:r").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, s ...

这个改动就大了。

wzsy2_mrf

qing0408 发表于 2019-3-11 11:19
r = .Columns("k:r").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, s ...

Sub test()
    Dim r%, i%, j%, c%, str$
    Dim arr, brr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    str = "k,m,o,q"
    With Worksheets("sheet1")
        brr = Split(str, ",")
        For c = 0 To UBound(brr)
            r = .Columns(brr(c) & ":" & brr(c)).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            arr = .Range(brr(c) & "3:" & brr(c) & r)
            For j = 1 To UBound(arr, 2)
                For i = 1 To UBound(arr)
                    If Len(arr(i, j)) <> 0 Then
                        d(arr(i, j)) = ""
                    End If
                Next
            Next
        Next
        .Range("a2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    End With
End Sub

wzsy2_mrf

活剥了chxw68的代码。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, pos, i, j, dic
  Set dic = CreateObject("scripting.dictionary")
  pos = Split("K m o q")
  For i = 0 To UBound(pos)
    arr = Range(pos(i) & "1").Resize(Cells(Rows.Count, pos(i)).End(xlUp).Row)
    For j = 3 To UBound(arr, 1)
      If Len(arr(j, 1)) Then dic(arr(j, 1)) = j
  Next j, i
  [a2].Resize(dic.Count) = Application.Transpose(dic.keys)
End Sub

qing0408

非常感谢chxw68老师，wzsy2_mrf老师，一把小刀闯天下老师的无私帮助。