VBA在Excel中合并包含相同文本的非相邻单元格

Question

我在Excel中创建了一个自动将日历信息从表格映射到动态日历视图的日历。每行表示从上午8点到下午6点的时间，每列表示周日至周六的一周中的某一天。我能够将每个独特事件的信息映射到每个列中的两个单独的单元格，一个用于开始时间，另一个用于结束时间。我正在寻找帮助，建立一个宏来合并包含相同信息的单元格，以便日历具有内聚性。例如。活动A从上午9点开始，于上午11点结束。目前在上午9点有一个单元，上午11点有一个单元，但10点的单元是空白的，我想将9AM单元中的两个单元合并到11AM单元。由于填充的单元格不总是相邻的，所以在这种情况下，偏移函数似乎不起作用。

这里是我想要实现的伪代码：

1. 对于每一列在指定区域
2. 循环的每一行
3. 如果两个细胞都含有相同的文字
4. 合并这些两个单元

这里是代码的一点我已经成功地拿出这么远。你可以知道有很多差距，可能是语法错误：

Sub MergeCells 
Dim cells As String 
cells = ActiveSheet.Range("C8:V28,C31:V51,C54:V74,C77:V97,C100:V120") 
    If ActiveSheet.Range(cells).??? Then 
     ActiveSheet.Range(cells).Merge 
    End If 
End Sub 

任何帮助将不胜感激！

Before picture

After picture

Answer 1

好了 - 这可能是矫枉过正，你可能需要调整，但这是有趣的努力。

Sub combine_Same() 
Application.DisplayAlerts = False 

Dim tableRng As Range 
Dim i As Long, k As Long, lastRow As Long 
Dim curText As Range, prevText As Range 

Dim tableRanges As Variant 

tableRanges = Split("b3:e20,C31:V51,C54:V74,C77:V97,C100:V120", ",") 

Dim rng  As Long 

For rng = LBound(tableRanges) To UBound(tableRanges) 
    Debug.Print "Working with: " & tableRanges(rng) 
    Set tableRng = Range(tableRanges(rng)) 
' tableRng.Select 
    lastRow = tableRng.Rows(tableRng.Rows.Count).Row 
    For k = tableRng.Columns(1).Column To tableRng.Columns.Count 
     For i = lastRow To tableRng.Rows(1).Row Step -1 
      Set curText = Cells(i, k) 
      Set prevText = curText.End(xlUp) 
      If curText.Value = prevText.Value And Not IsEmpty(curText) Then 
       'curText.Select 
       Range(curText, prevText).Merge 
       curText.VerticalAlignment = xlCenter 
      ElseIf curText.Value = curText.Offset(-1, 0).Value And Not IsEmpty(curText) Then 
       'curText.Select 
       Range(curText, curText.Offset(-1, 0)).Merge 
       curText.VerticalAlignment = xlCenter 
      End If 
     Next i 
    Next k 
Next rng 
Application.DisplayAlerts = True 
End Sub