Repeating merged cell range - vba

Question

I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas

Answer 1

Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub

Answer 2

You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub