重复合并单元格范围答案

【问题标题】：Repeating merged cell range重复合并单元格范围
【发布时间】：2014-12-11 12:17:52
【问题描述】：

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

任何想法

【问题讨论】：

或者...我可以根据 R 列中的重复值合并 A:T 列中的单元格吗？

标签： vba excel

【解决方案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

【讨论】：

您好，感谢您的回复。 'mergeOtherCells' 没有定义？
'mergeOtherCells' 是从您的 Sub MergeCells() 调用的第二个 Sub 的名称 - 大约在第 20 行。'mergeOtherCells' Sub 在我的答案中定义。您是否收到错误消息？

【解决方案2】：

你也可以试试下面的代码。这将要求您在 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

【讨论】：