Slow VBA Code optimisation - vba

Question

I´m pretty new to VBA and since it´s making my job so much easier I try to write some codes from time to time and everything works fine except for this one, I already tried with the Screen Updating and the Status Bar method but it´s still very slow. Any ideas on how it coul be improved? Thnak you
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1
Do Until i > LastRow
If Range("B" & i) = Range(B & i + 1) Then
Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
Range("A" & i + 1).EntireRow.Delete
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub

Answer 1

This does what your code does; i tested with 1k rows of data and it was faster then your code. (Updated with ja72's input)
Dim i As Long
Dim LastRow As Long
If Range("B1") = Range("B2") Then
Rows(1).Copy
Rows(1).Insert Shift:=xlDown
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
Cells(1, 12).Resize(, 5).FillRight
End If
Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value
Rows(2 & ":" & Rows.Count).Delete

Answer 2

The code below first addresses the issue of string math for the range picking. Instead of .Range("A" & i) it best to use .Offset() or .Cells() instead. Additionally it makes it explicit that we are dealing with values and not ranges when the math takes place. It is recommended to always type .Value where it is implied.
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range, g As Range
' Set the start of the optimization loop
Set r = Range("B1")
' While still inside the data
Do While r.Row <= LastRow
' Check this value with value of next row
If r.Value = r.Offset(1, 0).Value Then
Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
Go from "L" to "Q"
For i = 1 To 6
'Add values one by one with row below
g.Offset(0, i - 1).Value = _
g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
Next i
r.Offset(1, 0).EntireRow.Delete
LastRow = LastRow - 1
End If
' Move to next row
Set r = r.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Depending on the total amount of data, it will be way faster to load all the data into memory and process it with VBA arrays only to be returned back in the end to the worksheet.
The following code should be orders of magnitude faster.
Sub DW2()
Dim i As Long, j As Long, i_out As Long, i_next As Long
Dim LastRow As Long, ValCol As Long, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ValCol = Cells(, "L").Column
LastCol = Cells(, "Q").Column
Dim r_data As Range
' Reference all the data (filled rows, and 17 columns "A:Q")
Set r_data = Range("A1").Resize(LastRow, LastCol)
' x is input data, y as output data
Dim x() As Variant, y() As Variant
' Copy all the table cells into memory
x = r_data.Value
' Create an empty array at least the same size
ReDim y(1 To LastRow, 1 To LastCol)
' i_out is index for output
i_out = 1
' i is index for input
For i = 1 To LastRow
' Debug.Print "Row"; i, "into Row:"; i_out
'Copy all values first from current row
For j = 1 To LastCol
y(i_out, j) = x(i, j)
Next j
' Index i_next peeks at the next row
i_next = i + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
' Check with value match on 2nd column "B"
Do While x(i, 2) = x(i_next, 2)
'Add up values in columns 11 through 17
For j = ValCol To LastCol
y(i_out, j) = y(i_out, j) + x(i_next, j)
Next j
' Peek at subsequent rows also
i_next = i_next + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
Loop
' Advance i if rows were skipped
i = i_next - 1
' Advance i_out
i_out = i_out + 1
Next i
' Clear all table cells
r_data.ClearContents
' Overwrite with the optimized values
r_data.Resize(i_out - 1, LastCol).Value = y
End Sub
Edit: Now tested for robustness when matching rows exist in the end of the data