VBA-將列范圍值復制到特定工作表，刪除重復項

Question

我試圖復制活動工作表上的特定范圍，然后將這些值添加到同一工作簿中不同工作表上的現有列表中。

完成之后，我要刪除已添加的所有重復項。

Sub CopyUnique()
    Dim s1 As Worksheet, s2 As Worksheet, FirstEmptyRow As Long, expCol As Long
    Set s1 = ActiveSheet
    Set s2 = Sheets("Products")
    Range("A:A").Cells.Name = "types"
    expCol = Range("types").Column
    FirstEmptyRow = Cells(Rows.Count, expCol).End(xlUp).Row + 1
    s1.Range("C4:C33").Copy s2.Range(FirstEmptyRow)
    s2.Range("Products").Column.RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

我對VBA相當陌生，我可能盯着它看了太長時間，但是我對上面的代碼沒有任何幫助。

任何建議表示贊賞。

Answer 1

你可以試試這個

Sub CopyUnique()
    Dim s1 As Worksheet, FirstEmptyRow As Long, expCol As Long
    Set s1 = ActiveSheet
    With Sheets("Products")
        .Range("A:A").Name = "types"
        expCol = .Range("types").Column
        FirstEmptyRow = .Cells(.Rows.Count, expCol).End(xlUp).Row + 1
        s1.Range("C4:C33").Copy .Cells(FirstEmptyRow, expCol)
        .Range("types").RemoveDuplicates Columns:=1, Header:=xlNo
    End With
End Sub

但是從您的代碼中我可以看到，您可以將其簡化為：

Sub CopyUnique()
    Dim s1 As Worksheet
    Set s1 = ActiveSheet
    With Sheets("Products")
        s1.Range("C4:C33").Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
        Intersect(.UsedRange, .Columns(1)).RemoveDuplicates Columns:=1, Header:=xlNo
        .Range("A" & .Cells(.Rows.Count, 1).End(xlUp)).Name = "types"
    End With
End Sub

Answer 2

您可以嘗試在我的個人Macro工作簿中收藏的此功能：

Function rngToUniqueArr(ByVal rng As Range) As Variant

    'Reference to [Microsoft Scripting Runtime] Required
    Dim dict As New Scripting.Dictionary, cel As Range
    For Each cel In rng.Cells
        dict(cel.Value) = 1
    Next cel
    rngToUniqueArr = dict.Keys

End Function

注意：您將需要創建對Microsoft腳本運行時庫的引用

與新的子項一起使用時：

Sub CopyUnique()

    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = ThisWorkbook.ActiveSheet
    Set s2 = ThisWorkbook.Worksheets("Products")

    Dim rngToCopy As Range, valArr() As Variant
    Set rngToCopy = s1.UsedRange.Columns("A")
    valArr = rngToUniqueArr(rngToCopy)

    ' A10 start is an example. You may start at any row by changing the below value
    Dim copyToRng As Range
    Set copyToRng = s2.Range("A10:A" & 10 + UBound(valArr))

    With Application.WorksheetFunction
        copyToRng = .Transpose(valArr)
    End With

End Sub

本質上，使用此字典，您將創建唯一的“鍵”，並將字典的結果輸出到數組。

您需要transpose此數組的原因是它是一維的。 Excel中的一維數組是一條水平線，因此我們將其設置為垂直。 您還可以創建一個二維數組來避免使用Transpose ，但是這樣做通常是比較容易的事情。