Question

如何使用vba代码将唯一值从一个Excel工作表中的列复制到另一个Excel工作表中的一行？

我在sheet1列B中有一个包含重复项的值列表，我想将它复制到第2页第1行，没有重复项，我试过了：

Public Sub Test()

ActiveSheet.Range("B2:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets(2).Range("D1"), Unique:=True

End Sub

但它不起作用，也没有使用并非所有列都包含值的事实。

我该怎么做？

Answer 1

尝试 MAIN

Sub MAIN()
    Dim N As Long
    Dim cl As Collection
    N = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
    Set cl = MakeColl(ActiveSheet.Range("B1:B" & N))
    Call FillRange(Sheets(2).Range("D1:IV1"), cl)
End Sub

Public Function MakeColl(rng As Range) As Collection
    Set MakeColl = New Collection
    Dim r As Range
    On Error Resume Next
    For Each r In rng
        v = r.Value
        If v <> "" Then
            MakeColl.Add v, CStr(v)
        End If
    Next r
End Function

Sub FillRange(rng As Range, col As Collection)
    Dim I As Long, r As Range, J As Long
    I = 1
    J = col.Count
    For Each r In rng
        MsgBox r.Parent.Name & r.Address(0, 0)
        r.Value = col.Item(I)
        If I = J Then Exit Sub
        I = I + 1
    Next r
End Sub

Answer 2

Sub getUnique（）

Dim oWs As Worksheet：设置oWs = ActiveSheet Dim oRg As Range：设置oRg = oWs.Range（“B2：B65536”） Dim oRg_tmp As Range

oRg.AdvancedFilter动作：= xlFilterInPlace，唯一：=真

对于oRg.Rows.SpecialCells（xlCellTypeVisible）中的每个oRg_tmp。行 MsgBox“Heres a row，现在抓住你想要的东西：”＆amp; oRg_tmp.row 下一步

End Sub

从列到行复制唯一值

2 个答案: