Question

我要做的是梳理一列并从该列中提取所有唯一标识符，然后将结果粘贴到另一个工作表的表格中。我找到了下面的代码，它非常接近我的需求。但是，我有两个主要问题，我无法弄清楚。首先，该宏搜索的区域是常数，即＆＃34; A1：B50＆＃34;。我需要将其作为一个列并且是动态的，因为更多数据和新的唯一标识符将添加到此工作表中。其次，我无法弄清楚如何将我的结果粘贴到不同工作表上的特定范围。例如，如果我想将结果粘贴到＆＃34; sheet2＆＃34;从＆＃34; B5＆＃34;开始并且无论多长时间，唯一标识符列表都是。

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

Answer 1

稍作修改即可;关键是定义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

Answer 2

我认为你的解决方案比它需要的更棘手。如果使用Dictionary而不是列表，收集唯一ID变得几乎无关紧要。额外的好处是，随着数据集变大，字典将比列表更好地扩展。

下面的代码应该为您提供一个良好的起点，让您前进。为方便起见，我使用了你帖子中的参考文献。因此输出将在sheet2上从单元格B5开始下降并且假设输入在sheet1单元格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

从一列收集唯一标识符并将结果粘贴到不同的工作表中。

2 个答案: