Vba 从一列中收集唯一标识符，并将结果粘贴到其他工作表中。

我要做的是梳理一列并从该列中提取所有唯一标识符，然后将结果粘贴到另一个工作表中的表中。我发现下面的代码，它是非常接近我需要的。然而，我有两个主要的问题，我无法解决。首先，该宏搜索的区域是常量，即A1:B50。我需要这是一列和动态的，因为更多的数据和新的唯一标识符将被添加到此工作表。其次，我不知道如何将结果粘贴到不同工作表上的特定范围。例如，如果我想将结果粘贴到sheet2中，从B5开始，直到唯一标识符列表的长度

Sub ExtractUniqueEntries()
 Const ProductSheetName = "Sheet1" ' change as appropriate
 Const ProductRange = "B2:B"
 Const ResultsCol = "E"
 Dim productWS As Worksheet
 Dim uniqueList() As String
 Dim productsList As Range
 Dim anyProduct
 Dim LC As Integer

 ReDim uniqueList(1 To 1)
 Set productWS = Worksheets(ProductSheetName)
 Set productsList = productWS.Range(ProductRange)
 Application.ScreenUpdating = False
 For Each anyProduct In productsList
   If Not IsEmpty(anyProduct) Then
     If Trim(anyProduct) <> "" Then
       For LC = LBound(uniqueList) To UBound(uniqueList)
         If Trim(anyProduct) = uniqueList(LC) Then
           Exit For ' found match, exit
         End If
       Next
       If LC > UBound(uniqueList) Then
         'new item, add it
         uniqueList(UBound(uniqueList)) = Trim(anyProduct)
         'make room for another
         ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
       End If
     End If
   End If
 Next ' end anyProduct loop
 If UBound(uniqueList) > 1 Then
   'remove empty element
   ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
 End If
 'clear out any previous entries in results column
   If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
   productWS.Range(ResultsCol & 2 & ":" & _
    productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
 End If
 'list the unique items found
 For LC = LBound(uniqueList) To UBound(uniqueList)
   productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
    uniqueList(LC)
 Next
    'housekeeping cleanup
    Set productsList = Nothing
    Set productWS = Nothing
End Sub

---

稍加修改即可；关键是定义ProductRange

Sub ExtractUniqueEntries()
 Const ProductSheetName = "Sheet1" ' change as appropriate
 Dim ProductRange
 ProductRange = "B2:B" & Range("B" & Cells.Rows.Count).End(xlUp).Row
 Const ResultsCol = "E"
 Dim productWS As Worksheet
 Dim uniqueList() As String
 Dim productsList As Range
 Dim anyProduct
 Dim LC As Integer

 ReDim uniqueList(1 To 1)
 Set productWS = Worksheets(ProductSheetName)
 Set productsList = productWS.Range(ProductRange)
 Application.ScreenUpdating = False
 For Each anyProduct In productsList
   If Not IsEmpty(anyProduct) Then
     If Trim(anyProduct) <> "" Then
       For LC = LBound(uniqueList) To UBound(uniqueList)
         If Trim(anyProduct) = uniqueList(LC) Then
           Exit For ' found match, exit
         End If
       Next
       If LC > UBound(uniqueList) Then
         'new item, add it
         uniqueList(UBound(uniqueList)) = Trim(anyProduct)
         'make room for another
         ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
       End If
     End If
   End If
 Next ' end anyProduct loop
 If UBound(uniqueList) > 1 Then
   'remove empty element
   ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
 End If
 'clear out any previous entries in results column
   If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
   productWS.Range(ResultsCol & 2 & ":" & _
    productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
 End If
 'list the unique items found
 For LC = LBound(uniqueList) To UBound(uniqueList)
   productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
    uniqueList(LC)
 Next
    'housekeeping cleanup
    Set productsList = Nothing
    Set productWS = Nothing
End Sub

---

我认为你的解决方案比需要的要复杂一些。如果使用字典而不是列表，收集唯一ID几乎变得微不足道。另一个好处是，随着数据集的增大，字典的伸缩性会比列表好得多

下面的代码应该为您提供一个很好的出发点。为了方便起见，我使用了你文章中的参考资料。因此，输出将在第2页上，从单元格B5开始向下，输入假定在第1页单元格B2上向下

如果你有任何问题，请告诉我

    Option Explicit

    Sub ExtractUniqueEntries()
        'enable microsoft scripting runtime --> tools - references

        Dim unique_ids As New Dictionary
        Dim cursor As Range: Set cursor = ThisWorkbook.Sheets("Sheet1").Range("B2") 'change as Required

        'collect the unique ids
        'This assumes that:
        '1. ids do not contain blank rows.
        '2. ids are properly formatted. Should this not be the could you'll need to do some validating.
        While Not IsEmpty(cursor)
            unique_ids(cursor.Value) = ""
            Set cursor = cursor.Offset(RowOffset:=1)
        Wend

        'output the ids to some target.
        'assumes the output area is blank.
        Dim target As Range: Set target = ThisWorkbook.Sheets("Sheet2").Range("B5")
        Dim id_ As Variant
        For Each id_ In unique_ids
            target = id_
            Set target = target.Offset(RowOffset:=1)
        Next id_
    End Sub