重复合并的单元格范围 [英] Repeating merged cell range

问题描述

我有以下基本脚本将列R中的单元格与相同的值合并

  Sub MergeCells（）
 
 Application.ScreenUpdating = False 
 Application.DisplayAlerts = False 
 
 Dim rngMerge As Range，cell As Range 
设置rngMerge = Range（R1：R1000） 
 
 MergeAgain：
对于每个单元格在rngMerge 
如果cell.Value = cell.Offset（1，0）.Value和IsEmpty（cell）= False然后
 Range（cell，cell.Offset（1，0））。Merge 
 GoTo MergeAgain 
 End If 
 Next 
 
 Application.DisplayAlerts = True 
应用程序.ScreenUpdating = True 
 
 End Sub 
  

我想做的是在列A：Q和S：T中重复此操作，但是我希望将这些列合并到与列R相同的合并单元格范围内，即如果R2：R23合并，则A2：A23，B2：B23，C2：C23列表A：Q不包含值，列S：T具有值，但这些将为b

解决方案

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 
 
对于c = mergeRowStart要mergeRowEnd 
设置currcell =单元格（c，mergeCol）
如果currcell.Value = currcell.Offset（1，0）.Value和IsEmpty（currcell ）= False然后
 cval = currcell.Value 
 strow = currcell.Row 
 endrow = strow + 1 
尽管cval = currcell.Offset（endrow  -  strow，0）。价值而不是IsEmpty（currcell）
 endrow = endrow + 1 
 c = c + 1 
循环
如果endrow> strow + 1然后
调用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 
对于col = 1到20 
范围（Cells（strw，col），Cells（enrw，col））。合并
下一个col 
 End Sub 
  

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

解决方案

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

这篇关于重复合并的单元格范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！