Question

我有以下基本脚本，它在列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具有值但是，这些值在整个范围内都是相同的值。

任何想法

Answer 1

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

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

您也可以尝试以下代码。它需要你在R（R1001）列的最后一行之后放一个'No'，以便结束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

重复合并的单元格范围

2 个答案: