У меня были подобные требования несколько раз за эти годы, поэтому я запрограммировал общий режим. Я потерял источник этой рутины и перекодировал по памяти. Я протестировал новую версию, но не могу абсолютно гарантировать, что она не содержит ошибок, поэтому сделайте копию своих данных, прежде чем попробовать.
Процедура опирается на два массива. ColMatch сообщает, какие столбцы должны совпадать для двух строк. ColMerge сообщает, какие столбцы объединить. Каждый столбец должен быть указан в одном из этих массивов.
Для моих тестовых данных я сопоставляю столбцы 1, 2, 3 и 5 и объединяю столбцы 4 и 6. Я определяю это так:
ColMatch = Array(1, 2, 3, 5)
ColMerge = Array(4, 6)
Вам придется изменить эти заявления в соответствии с вашими требованиями. Ваш вопрос подразумевает, что они должны быть:
ColMatch = Array(1, 3, 4)
ColMerge = Array(2)
В подпрограмме также используется постоянный разделитель, который помещается перед каждым добавленным значением. Я установил его в vbLf, поэтому я получаю каждое значение в отдельной строке. Вы хотите запятую, так что:
Const Separator As String = ","
Я не думаю, что есть что-то еще, что вам нужно изменить. Тем не менее, я полагаю, вы тщательно работаете над макросом. Я надеюсь, что я включил достаточно комментариев для вас, чтобы понять, как это работает. Вернись с вопросами, если это необходимо.
В моей системе требуется около 2 минут для обработки 51 800 строк, поэтому я использую строку состояния в качестве грубого индикатора прогресса.
Это показывает начальное состояние моих тестовых данных.
Это показывает, как он изменился после запуска макроса.
Надеюсь это поможет.
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
