VBA - 将列范围值复制到特定工作表，删除重复项答案

【问题标题】：VBA - Copy column range values to specific sheet, remove duplicatesVBA - 将列范围值复制到特定工作表，删除重复项
【发布时间】：2018-02-21 23:12:16
【问题描述】：

我正在尝试复制活动工作表上的特定范围，然后将这些值添加到同一工作簿中不同工作表上的现有列表中。

完成后，我想删除已添加的所有重复项。

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 比较陌生，我可能已经盯着这个太久了，但是我对上面的代码没有任何基础。

感谢任何建议。

【问题讨论】：

所以你解释了你想要做什么，但你能告诉我们什么不起作用吗？您是否收到错误消息？你有意想不到的结果吗？
我很抱歉！我实际上没有从代码中得到任何结果。工作表上根本没有显示任何内容。

标签： excel vba

【解决方案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

【讨论】：

效果很好，非常感谢。它复制了我所有的格式/单元格边框，并在删除重复项时计算了这些因素。但这给了我一个很好的机会来解决一些问题。谢谢！
不客气。如果您只想粘贴值，您可以使用 '.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(30).Value = s1.Range("C4:C33")。 Value' 而不是 ,s1.Range("C4:C33").Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)'

【解决方案2】：

你可以试试我收藏在我个人宏工作簿中的这个功能：

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，但这样做通常更容易。

【讨论】：