求修改代码按列提取唯一列

hfvung

详情请看附件： 求修改代码A.rar (18.44 KB, 下载次数: 11)

2024-8-8 22:02 上传

点击文件名下载附件

醉眼看尘世

参与一下，参考代码：

1. Sub test()
   
2. Dim Dic As Object, Arr, i&, j&, tmPstr$, mcol&
   
3. Set Dic = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     Arr = .[b2].CurrentRegion
   
6.     For j = 1 To UBound(Arr, 2)
   
7.         tmPstr = ""
   
8.         For i = 1 To UBound(Arr, 1)
   
9.             If tmPstr = "" Then tmPstr = Arr(i, j) Else tmPstr = tmPstr & Chr(10) & Arr(i, j)
   
10.         Next i
    
11.         Dic(tmPstr) = ""
    
12.     Next j
    
13.    
    
14.     ReDim Brr(1 To UBound(Arr, 1), 1 To Dic.Count)
    
15.     mcol = 0
    
16.     For Each d In Dic.keys
    
17.         mcol = mcol + 1
    
18.         Trr = Split(d, Chr(10))
    
19.         For i = 0 To UBound(Trr)
    
20.             Brr(i + 1, mcol) = Val(Trr(i))
    
21.         Next i
    
22.     Next d
    
23.    
    
24. End With
    
25. With Sheet2
    
26.     .UsedRange.ClearContents
    
27.     .[b2].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
28. End With
    
29. End Sub
    

复制代码

quqiyuan

从新写了一下，仅供参考，，，

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.[b2].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For j = 1 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            s = arr(i, j)
            If Len(s) > 0 Then ss = ss & s
        Next
        If Not d.exists(ss) Then d(ss) = j
        ss = Empty
    Next
    Dim rng As Range
    For Each k In d.items
        If rng Is Nothing Then
            Set rng = Sheet1.Columns(k + 1)
        Else
            Set rng = Union(rng, Sheet1.Columns(k + 1))
        End If
    Next
    Set rng = Intersect(rng, Sheet1.UsedRange)
    rng.Copy Sheet2.[b1]
    Set d = Nothing
    Beep
End Sub

longwin

新写了一段：
Sub test()
Set d = CreateObject("scripting.dictionary")
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")
arr = sh1.[b2].CurrentRegion.Value
For j = 1 To UBound(arr, 2)
    ss = Join(WorksheetFunction.Transpose(WorksheetFunction.Index(arr, 0, j)), "-")
    For i = 1 To UBound(arr)
    d(ss) = j + 1
    Next
Next
m = 1
For Each k In d.keys
    j = d(k)
    m = m + 1
    sh1.Range(sh1.Cells(2, j), sh1.Cells(UBound(arr) + 1, j)).Copy sh2.Range(sh2.Cells(2, m), sh2.Cells(UBound(arr) + 1, m))
Next
Set d = Nothing
MsgBox "OK!"

End Sub

一招秒杀

行列转置后，仅需几个关键字就瞬间秒杀了，完全没有任何计算符号或者函数，简单得不要不要的，哪里需要写几十行代码啊，又是变量+数组 +字典，循环套循环，都到了查打一体无人机的时代，还在用小米+步枪，感觉回到了石器时代，太原始落后了。

一招秒杀

=TRANSPOSE(UNIQUE(TRANSPOSE(B2:S18)))   转置  取唯一 再转置，公式 可以解决的，就不麻烦 VBA代码了。

saghj

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, i&, j&, dic As Object, t#, Rng As Range, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    With Worksheets(1).[B2].CurrentRegion
        ar = .Value
        For j = 1 To UBound(ar, 2)
            strKey = ""
            For i = 1 To UBound(ar)
                strKey = strKey & ar(i, j)
            Next i
            If Not dic.exists(strKey) Then
                dic(strKey) = Empty
                If Rng Is Nothing Then
                    Set Rng = .Columns(j)
                Else
                    Set Rng = Union(Rng, .Columns(j))
                End If
            End If
        Next j
    End With
   
    With Worksheets(2)
        .Cells.Clear
        Rng.Copy .[B2]
        .Activate
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

参与一下。。。