Question

我有一个excel工作表，其中包含两列，分别称为ProductName和CountryCode。我希望根据“ ProductName”列中的相应值，将所有由/分隔的CountryCode串联起来，而我的输出将在称为“ FinalResults”。请注意，我使用删除重复函数从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)

您只能为what指定Find参数。因此，其他参数默认为一些不受控制的值。通常，after参数将默认为范围的开头，因此您将Find与PRO1的第一个匹配项放在A3中。另外，由于SG默认为lookat并且xlPart包含在PRO1中，因此正在拾取第二个PRO10。

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

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

根据分配给另一列的值，将用“ /”分隔的一列中的值串联起来

3 个答案: