Repeating merged cell range

问题

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

回答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

回答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

来源：https://stackoverflow.com/questions/26399189/repeating-merged-cell-range

标签

excel

vba

excel-vba