Группировка двух столбцов для уменьшения количества строк путем сравнения | оптимизация кода

Question

Я пытаюсь найти решение vba для следующей проблемы:

У меня есть два столбца, и я пытаюсь сгруппировать column1 запятым, чтобы было меньше строк.

например,

пример:

Я попробовал это, и это сработало - но это заняло слишком много времени (около 300 000 строк). Есть ли лучшее решение этой задачи?

* Это только одна часть моего макроса

For Each r In fr
    If st = "" Then
        st = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
    Else
        If Not IsInArray(Split(st, ","), ws.Cells(r.row, "L").Value) Then
            st = st & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
        End If
    End If
    If usrCheck = True Then
        If str = "" Then
            str = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
        Else
            If Not IsInArray(Split(str, ","), ws.Cells(r.row, "A").Value) Then
                str = str & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
            End If
        End If
    End If
Next

Answer 1

Может быть, использование Dictionary будет быстрым. Как насчет:

Sub Test()

Dim x As Long, lr As Long, arr As Variant
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")

With Sheet1 'Change accordingly

    'Return your last row from column A
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row

    'Get array and loop through it
    arr = .Range("A2:B" & lr).Value
    For x = LBound(arr) To UBound(arr)
        dict1(arr(x, 2)) = arr(x, 2)
    Next

    'Loop through dictionary filling a second one
    For Each Key In dict1.keys
        For x = LBound(arr) To UBound(arr)
            If arr(x, 2) = Key Then dict2(arr(x, 1)) = arr(x, 1)
        Next x
        .Range("F" & .Cells(.Rows.Count, 6).End(xlUp).Row + 1) = Key
        .Range("G" & .Cells(.Rows.Count, 7).End(xlUp).Row + 1) = Join(dict2.Items, ", ")
        dict2.RemoveAll
    Next

End With

End Sub

Тем не менее, вы получите все уникальные предметы из столбца A, поэтому, если могут быть дубликаты, и вы хотите их сохранить, это не для вас =)

Answer 2

Попробуйте также, пожалуйста. Он работает только в памяти и на моем компьютере занимает менее 3 секунд для 300000 строк. Диапазон должен быть отфильтрован, как на вашей картинке. В противном случае фильтрация также может быть легко автоматизирована.

Private Sub CondensData()
 Dim sh As Worksheet, arrInit As Variant, arrIn As Variant, i As Long
 Dim arrFinal() As Variant, lastRow As Long, Nr As Long, El As Variant
 Dim strTemp As String, k As Long

 Set sh = ActiveSheet
  lastRow = sh.Cells(sh.Rows.count, "A").End(xlUp).Row
  arrIn = sh.Range("B2:B" & lastRow + 1).Value
  'Determine the number of the same accurrences:
  For Each El In arrIn
      i = i + 1
      If i >= 2 Then
        If arrIn(i, 1) <> arrIn(i - 1, 1) Then Nr = Nr + 1
      End If
  Next
  ReDim arrFinal(Nr, 1)

  arrInit = sh.Range("A2:B" & lastRow).Value
  For i = 2 To UBound(arrInit, 1)
      If i = 1 Then
            strTemp = arrInit(1, 1)
      Else
         If arrInit(i, 2) = arrInit(i - 1, 2) Then
            If strTemp = "" Then
                strTemp = arrInit(i, 1)
            Else
                strTemp = strTemp & ", " & arrInit(i, 1)
            End If
         Else
            arrFinal(k, 0) = arrInit(i - 1, 2)
            arrFinal(k, 1) = strTemp
            k = k + 1: strTemp = ""
         End If
      End If
  Next i
  sh.Range("C2:D" & lastRow).Clear
  sh.Range("C2:D" & k - 1).Value = arrFinal
  sh.Range("C:D").EntireColumn.AutoFit
  MsgBox "Solved..."
End Sub

Она вернет результат в столбцах C: D