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

Question

我正在Excel中建立日历，该日历会自动将事件信息从表格映射到动态日历视图。 每行代表从上午8点至下午6点的时间，每列代表从星期日至星期六的一周中的一天。 我能够将每个唯一事件的信息映射到每一列中的两个单独的单元格，一个用于开始时间，一个用于结束时间。 我正在寻求有关构建宏的帮助，以将包含相同信息的单元格合并为一个宏，因此日历具有凝聚力。 例如，事件A在9AM开始，在11AM结束。 当前在9AM填充一个单元，在11AM填充一个单元，但是10AM的单元为空白，我想将两个填充的单元从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

任何帮助将不胜感激！

图片前

后图片

Answer 1

好的-这可能是矫kill过正，您可能需要进行调整，但这很有趣。

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