Merging over 2000 Cells using VBA? - vba

Question

I have wrote the following code to merge cells in excel, the data is around 26000 rows, the code is running on core I7 CPU with 8 GB RAM, the problem that it still working since 4 days, the average rows per day is 3000 row!, any one know how to get the result, because its a report that should be delivered since three days!
Sub MergeCellss()
lastRow = Worksheets("A").Range("A65536").End(xlUp).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
For i = 2 To lastRow
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value <> Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and <> +1 " & intUpper)
End If
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value = Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Application.DisplayAlerts = False
Debug.Print ("<> +1 and = -1:" & i & "LOWER LIMIT")
DoEvents
For x = 1 To 8
Range(Cells(intUpper, x), Cells(i, x)).Merge
Next x
For j = 18 To 26
Range(Cells(intUpper, j), Cells(i, j)).Merge
Next j
Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(i) & ","">0"")"
Range(Cells(intUpper, 14), Cells(i, 14)).Merge
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
Debug.Print ("One Cells: " & i)
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
Cells(intUpper, 14).Value = Cells(intUpper, 13).Value
DoEvents
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
the code above will merge the all cells containing repeated data like User Name, Date of Birth, .... into one cell, and leave the training courses and experiences as it is.
I wonder how can I run this code in less than 1 hour.

Answer 1

Here is some rewrite on your code. The two primary differences are the use of If ... ElseIf ... End If and the grouping of the first and fourth conditional operations (the conditions were the same).
Sub Merge_Cells()
Dim lastRow As Long, rw As Long
Dim intUpper As Long, x As Long
Dim vVALs As Variant
appTGGL bTGGL:=False
Debug.Print Timer
With Worksheets("A")
.Cells(1, 1) = Timer
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 2 To lastRow
vVALs = Array(.Cells(rw - 1, 2).Value, .Cells(rw, 2).Value, .Cells(rw + 1, 2).Value)
If vVALs(1) <> vVALs(0) And vVALs(1) <> vVALs(2) Then
'the first and fourth conditions were the same so they are both here
'original first If condition
intUpper = rw
'Debug.Print ("<> -1 and <> +1 " & intUpper)
'original fourth If condition
'Debug.Print ("One Cells: " & rw)
.Range(.Cells(rw, 1), .Cells(rw, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
.Cells(intUpper, 14).Value = .Cells(intUpper, 13).Value
ElseIf vVALs(1) <> vVALs(0) And vVALs(1) = vVALs(2) Then
intUpper = rw
'Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
ElseIf vVALs(1) = vVALs(0) And vVALs(1) <> vVALs(2) Then
'Debug.Print ("<> +1 and = -1:" & rw & "LOWER LIMIT")
For x = 1 To 26
If x < 9 Or x > 17 Then _
.Range(.Cells(intUpper, x), .Cells(rw, x)).Merge
Next x
.Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(rw) & ","">0"")"
.Range(.Cells(intUpper, 14), .Cells(rw, 14)).Merge
.Cells(rw, 1).Resize(1, 26).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
Next rw
.Cells(1, 2) = Timer
End With
Debug.Print Timer
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
End Sub
I've also read the three primary conditional values into a variant array to reduce repeated worksheet value reads.