Sub MergeCellsWithConditions() Dim i, arr, temp, temp_, r As Long, dC As Long, lr As Long r = 9: lr = Cells(r, 3).End(xlDown).Row: arr = Range(Cells(r, 1), Cells(lr, 7)) Application.DisplayAlerts = False For i = LBound(arr, 1) To UBound(arr, 1) If i = UBound(arr, 1) Then Exit For If arr(i, 2) = arr(i + 1, 2) Then temp = arr(i + 1, 7) + arr(i, 7): Range(Cells(r, 7), Cells(r + 1, 7)).Merge: Range(Cells(r, 7), Cells(r + 1, 7)) = temp temp_ = arr(i + 1, 6) + arr(i, 6): Range(Cells(r, 6), Cells(r + 1, 6)).Merge: Range(Cells(r, 6), Cells(r + 1, 6)) = temp_ i = i + 1: r = r + 2 Else r = r + 1 End If Next i Application.DisplayAlerts = True End Sub
[/vba] Запускать по Alt + F8
xXx, приветствую! Можно например так: [vba]
Код
Sub MergeCellsWithConditions() Dim i, arr, temp, temp_, r As Long, dC As Long, lr As Long r = 9: lr = Cells(r, 3).End(xlDown).Row: arr = Range(Cells(r, 1), Cells(lr, 7)) Application.DisplayAlerts = False For i = LBound(arr, 1) To UBound(arr, 1) If i = UBound(arr, 1) Then Exit For If arr(i, 2) = arr(i + 1, 2) Then temp = arr(i + 1, 7) + arr(i, 7): Range(Cells(r, 7), Cells(r + 1, 7)).Merge: Range(Cells(r, 7), Cells(r + 1, 7)) = temp temp_ = arr(i + 1, 6) + arr(i, 6): Range(Cells(r, 6), Cells(r + 1, 6)).Merge: Range(Cells(r, 6), Cells(r + 1, 6)) = temp_ i = i + 1: r = r + 2 Else r = r + 1 End If Next i Application.DisplayAlerts = True End Sub