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

转载请标明出处:Repeating merged cell range

文章来源: Repeating merged cell range