Excel VBA: Merging a range inside a loop - vba

Question

I want to merge that repeating Chapters into just one cell by Chapter.
Here is how my code does the looping.
Dim label As Control
Dim itm As Object
For ctr = 1 To InfoForm.Chapter.ListCount - 1
For Each label In InfoForm.Controls
If TypeName(label) = "Label" Then
With ActiveSheet
i = i + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If label <> "Chapter" Then
.Cells(lastColumn, i).Value = "Chapter " & ctr
.Cells(lastRow, i).Value = label.Caption
End If
End With
End If
Next
Next
I've tried merging it like this
.Range(Cells(1, lastColumn), Cells(1,i)).Merge
But it merges all the repeating chapters into one cell instead
Expected Result:

Answer 1

My method is bellow
Dim label As Control
Dim itm As Object
For ctr = 1 To InfoForm.Chapter.ListCount - 1
For Each label In InfoForm.Controls
If TypeName(label) = "Label" Then
With ActiveSheet
i = i + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If label <> "Chapter" Then
.Cells(lastColumn, i).Value = "Chapter " & ctr
.Cells(lastRow, i).Value = label.Caption
End If
End With
End If
Next
Next
'this is merge method
Dim rngDB As Range, rng As Range, n As Integer
Application.DisplayAlerts = False
Set rngDB = Range("a1", Cells(1, Columns.Count).End(xlToLeft))
For Each rng In rngDB
If rng <> "" Then
n = WorksheetFunction.CountIf(rngDB, rng)
rng.Resize(1, n).Merge
rng.HorizontalAlignment = xlCenter
End If
Next rng
Application.DisplayAlerts = True

Answer 2

How about this?
With ActiveSheet
firstCol = 1
lastCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
For i = 1 To lastCol
If .Cells(1, i) = "" Then GoTo NextCol 'skip blank cell
If firstCol = 0 And .Cells(1, i) <> "" Then firstCol = i 'set first column
If .Cells(1, i) = .Cells(1, i + 1) Then
LastColDup = i 'remember last duplicate column
Else
Application.DisplayAlerts = False
With .Range(Cells(1, firstCol), Cells(1, LastColDup + 1))
.Merge
.HorizontalAlignment = xlCenter
End With
Application.DisplayAlerts = True
firstCol = 0
LastColDup = 0
End If
NextCol:
Next i
End With

Answer 3

If you know the ranges before hand then you could adjust the code below. I've created this by recording a macro and then disabling/enabling alerts as appropriate. I've included a function to convert integer column values to alph equivalents.The MainLoop Intcol1 and intcol2 would be values that you would provide based on the input from the original Form.
Sub MainLoop()
Dim StrMycol_1 As String
Dim StrMycol_2 As String
Dim intcol1 As Integer
Dim intcol2 As Integer
intcol1 = 5: intcol2 = 7
StrMycol_1 = WColNm(intcol1) ' mycell.column is numeric. Function returns integer
StrMycol_2 = WColNm(intcol2) ' mycell.column is numeric. Function returns integer
'
do_merge_centre StrMycol_1, StrMycol_2
End Sub
Sub do_merge_centre(col1, col2)
Range(col1 + "1:" + col2 + "1").Select
Application.DisplayAlerts = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Application.DisplayAlerts = True
End Sub
'
Public Function WColNm(ColNum) As String
WColNm = Split(Cells(1, ColNum).Address, "$")(1)
End Function