Vba 重复合并单元格范围

我有下面的基本脚本，用于合并列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

我想在A:Q和S:T列中重复这一点，但我希望这些列合并到与R列相同的合并单元格范围中，即，如果R2:R23合并，则A2:A23、B2:B23、C2:C23等也将合并

列A:Q不包含值，列S:T包含值，但是，这些值在整个范围内都是相同的值

---

任何想法

对早期编辑的建议-现在处理col R中的多个副本。 请注意，此方法适用于当前（活动）工作表

---

您也可以尝试下面的代码。这将要求您在列R（R1001）的最后一行之后输入“否”，以便结束while循环

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

Sub宏1（）
Application.ScreenUpdating=False
Application.DisplayAlerts=False
flag=False
k=1
而ActiveSheet.Cells（k，18）.值为“否”
i=1
j=0
而我<1000
rowid=k
如果单元格（rowid，18）.Value=单元格（rowid+i，18）.Value则
j=j+1
flag=True
其他的
i=1000
如果结束
i=i+1
温德
如果flag=True，则
x=1
而x<21
范围（单元格（rowid，x），单元格（rowid+j，x））。合并
x=x+1
温德
flag=False
k=k+j
如果结束
k=k+1
温德
Application.DisplayAlerts=True
Application.ScreenUpdating=True
端接头

或者。。。我可以根据R列中的重复值合并A:T列中的单元格吗？您好，谢谢您的回复。”未定义mergeOtherCells？“mergeOtherCells”是从子MergeCells（）调用的第二个子单元的名称-大约在第20行。“mergeOtherCells”子项在我的回答中定义。您是否收到错误消息？

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