Eu tive requisitos como este algumas vezes ao longo dos anos, então eu codifiquei uma rotina geral. Perdi a fonte dessa rotina e gravei da memória. Eu testei a nova versão, mas não posso garantir absolutamente que ela esteja livre de erros, portanto, faça uma cópia dos seus dados antes de tentar.
A rotina depende de dois arrays. ColMatch informa quais colunas devem ser iguais para duas linhas para corresponder. ColMerge informa quais colunas serão mescladas. Cada coluna deve ser especificada em um desses arrays.
Para meus dados de teste, combino as colunas 1, 2, 3 e 5 e mescle as colunas 4 e 6. Defino isso assim:
ColMatch = Array(1, 2, 3, 5)
ColMerge = Array(4, 6)
Você terá que alterar essas declarações para seus requisitos. Sua pergunta implica que eles devem ser:
ColMatch = Array(1, 3, 4)
ColMerge = Array(2)
A rotina também usa uma constante Separador que é colocada antes de cada valor acrescentado. Eu configurei para vbLf, então eu recebo cada valor de uma linha diferente. Você quer vírgula, então:
Const Separator As String = ","
Eu não acho que haja mais nada que você precise mudar. No entanto, sugiro que você trabalhe com cuidado a macro. Espero ter incluído comentários suficientes para você entender como funciona. Volte com perguntas, se necessário.
No meu sistema, leva cerca de 2 minutos para processar 51.800 linhas, então eu uso a barra de status como um indicador bruto de progresso.
Isso mostra o estado inicial dos meus dados de teste.
Issomostracomoissomudoudepoisqueamacrofoiexecutada.
Espero que isso ajude.
Option Explicit
Sub MergeRows()
' Merges adjacent rows for which all columns listed in ColMatch are equal
' by appending the contents of the other columns from the second row to
' the first row and then deleting the second row.
Dim CheckOK As Boolean
Dim ColCrnt As Long
Dim ColLast As Long
Dim ColMatch() As Variant
Dim ColMerge() As Variant
Dim InxMatch As Long
Dim InxMerge As Long
Dim RowCrnt As Long
Dim RowLast As Long
Dim RowsMatch As Boolean
Dim TimeStart As Single
' Defines the first row to be considered for merging. This avoids
' looking at header rows (not very important) and allows a restart
' from row 600 or whatever (might be important).
Const rowDataFirst As Long = 2
' Defines the string to be placed between the value in the first row
' and the value from the second row.
Const Separator As String = vbLf
' Speeds up processing
Application.ScreenUpdating = False
' Stops the code from being interrupted by event routines
Application.EnableEvents = False
' Use status bar as a progress indicator
Application.DisplayStatusBar = True
' Record seconds since midnight at start of routine.
TimeStart = Timer
' Defines the columns which must have the same values in two
' adjacent rows for the second row to be merged into the
' first row. Column numbers must be in ascending order.
ColMatch = Array(1, 2, 3, 5)
' Defines the columns for which values from the second row
' are to be appended to the first row of a matching pair.
' Column numbers must be in ascending order. ColMatch and
' ColMerge together must specify every used column.
ColMerge = Array(4, 6)
' Replace "Merge" with the name of your worksheet
With Worksheets("Merge")
' Find last used column and last used row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByColumns, xlPrevious).Column
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByRows, xlPrevious).Row
' Validate column parameters. Every column must be specified once
' in either ColMatch or ColMerge.
InxMatch = 0 ' 0 = lower bound of array
InxMerge = 0
For ColCrnt = 1 To ColLast
CheckOK = False ' Set true if check successful
If InxMatch > UBound(ColMatch) Then
' ColMatch array exhausted
Else
If ColCrnt = ColMatch(InxMatch) Then
CheckOK = True
InxMatch = InxMatch + 1
End If
End If
If Not CheckOK Then
If InxMerge > UBound(ColMerge) Then
' ColMerge array exhausted
Else
If ColCrnt = ColMerge(InxMerge) Then
CheckOK = True
InxMerge = InxMerge + 1
End If
End If
End If
If Not CheckOK Then
Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
" ColMatch or ColMerge. Please correct and try again.", _
vbOKOnly)
Exit Sub
End If
Next
RowCrnt = rowDataFirst
Do While True
If RowCrnt Mod 100 = 0 Then
' Use status bar to indicate progress
Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
End If
' Attempt to match RowCrnt and RowCrnt+1
RowsMatch = True ' Assume match until find otherwise
For InxMatch = 0 To UBound(ColMatch)
ColCrnt = ColMatch(InxMatch)
If .Cells(RowCrnt, ColCrnt).Value <> _
.Cells(RowCrnt + 1, ColCrnt).Value Then
' Rows do not match
RowsMatch = False
Exit For
End If
Next
If RowsMatch Then
' Rows match. Merge second into first.
For InxMerge = 0 To UBound(ColMerge)
ColCrnt = ColMerge(InxMerge)
.Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
Separator & _
.Cells(RowCrnt + 1, ColCrnt).Value
Next
' Second row merged into first. Discard second row.
.Rows(RowCrnt + 1).EntireRow.Delete
' RowLast has moved up.
RowLast = RowLast - 1
' Do not step RowCrnt because there may be another match for it
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
Else
' Rows do not match. RowCrnt no longer of interest.
RowCrnt = RowCrnt + 1
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
End If
Loop
End With
' Output duration of macro to Immediate window
Debug.Print Format(Timer - TimeStart, "#,##0.00")
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub