Объединить значения в одном столбце, разделенные символом «/», на основе значений, назначенных другому столбцу.

Question

У меня есть лист Excel, который содержит два столбца с именами ProductName и CountryCode.i хотел объединить все CountryCode, разделенные / на основе соответствующих значений в столбце «ProductName», и мой вывод будет получен в отдельном столбце с именем « FinalResults. Обратите внимание, что я использовал функцию удаления дубликатов, чтобы получить уникальные значения в столбце C из столбца A.

Я попробовал приведенный ниже код VBA с помощью stackoverflow и получил результаты.

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

Если вы беспокоитесь о скорости, вы должны использовать массивы для обработки ваших данных:

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 2

Как видно из других ответов, есть много способов выполнить вашу задачу.

Но прочитайте VBA HELP для метода Range.Find Я отправляю следующее, чтобы помочь вам понять, где вы ошиблись:

Это ваша проблема:

Set FoundCell = SearchRange.Find(SearchCell)

Вы указываете аргумент what только для Find. Таким образом, другие аргументы по умолчанию имеют неконтролируемое значение. Как правило, аргумент after будет по умолчанию установлен на начало диапазона, поэтому первый соответствующий термин для Find для PRO1 будет в A3. Кроме того, выбирается 2-й SG, потому что lookat по умолчанию равен xlPart, а PRO1 содержится в PRO10.

Таким образом, одним из способов исправления этой части вашего кода будет указание всех соответствующих аргументов Find. например:

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

Answer 3

Я переписал это ...

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

... Я доволен вышеупомянутым, но это только я. Это означает, что данные не нужно сортировать, и они будут работать.

Добавьте формулу в свою ячейку и наблюдайте, как она работает.