根据分配给另一列的值连接由“/”分隔的一列中的值

Question

我有一个 Excel 表，其中包含名为 ProductName 和 CountryCode 的两列。我想根据“ProductName”列中的相应值连接所有由 / 分隔的 CountryCode，并且我的输出将在一个名为“”的单独列中获得最终结果”。请注意，我使用删除重复函数从 A 列获取 C 列中的唯一值。

我在 stackoverflow 的帮助下尝试了下面的 VBA 代码并得到了结果。

Sub ProductCountry()    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")    
    Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
    Dim MyString As String, i As Long

    Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
        SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
        ws.Range("C2").Delete Shift:=xlShiftUp

    Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)

    For Each SearchCell In Names
        Set FoundCell = SearchRange.Find(SearchCell)
            For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
                MyString = MyString & FoundCell.Offset(, 1) & "/"
                Set FoundCell = SearchRange.FindNext(FoundCell)
            Next i
        SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
        MyString = ""
    Next SearchCell
End Sub

除了第一个产品 PRO1 之外，它似乎工作正常。你可以看到它并没有按顺序连接代码，而是跳过了国家代码 US，取而代之的是国家代码 SG 两次。

任何人都可以帮助解决这个脚本中出了什么问题，如果我对大数据使用相同的代码，有时我也会遇到范围错误。

Answer 1

我重写了...

Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
    Application.Volatile

    Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
    Dim strCountry As String, lngBlank As Long

    For lngRow = 1 To rngCells.Rows.Count
        strThisProductName = Trim(rngCells.Cells(lngRow, 1))
        strCountry = Trim(rngCells.Cells(lngRow, 2))

        If strThisProductName & strCountry = "" Then
            lngBlank = lngBlank + 1
        Else
            lngBlank = 0

            If strProductName = strThisProductName Then
                ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
            End If
        End If

        If lngBlank = 10 Then Exit For
    Next

    If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function

...我对上述内容很满意，但这只是我自己。这意味着数据不需要排序并且可以工作。

将公式添加到您的单元格并观察它。

Answer 2

如果您关心速度，您应该使用数组来处理数据：

Option Explicit

Public Sub CollectList()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet2")

    'read values into array
    Dim InputValues() As Variant
    InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value

    Dim UniqueList As Object
    Set UniqueList = CreateObject("Scripting.Dictionary")

    'collect all products in a dictionary
    Dim iRow As Long
    For iRow = 1 To UBound(InputValues, 1)
        If UniqueList.Exists(InputValues(iRow, 1)) Then
            UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
        Else
            UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
        End If
    Next iRow

    'output dictionary into cells
    iRow = 2 'start output in row 2
    Dim itm As Variant
    For Each itm In UniqueList
        ws.Cells(iRow, "C").Value = itm
        ws.Cells(iRow, "D").Value = UniqueList(itm)
        iRow = iRow + 1
    Next itm
End Sub

Answer 3

从其他回复可以看出，有很多方法可以完成您的任务。

但请阅读 VBA HELP 以了解 Range.Find 方法 我提交以下内容以帮助您了解您出错的地方：

这是你的问题线：

Set FoundCell = SearchRange.Find(SearchCell)

您只需为Find 指定what 参数。所以其他参数默认为一些不受控制的值。通常，after 参数将默认为范围的开头，因此Find 与PRO1 的第一个匹配项将在A3 中。此外，第二个SG 被选中，因为lookat 默认为xlPart，而PRO1 包含在PRO10 中。

因此，纠正这部分代码的一种方法是确保指定Find 的所有相关参数。例如：

Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)