В Excel, как я могу использовать VBA для динамического объединения ячеек с одинаковым значением?

Question

Я создаю Excel для управления проектами, и по части Ганта, было бы хорошо иметь в качестве информации дни и недели.

Как вы можете видеть на рисунке, полоса прокрутки вверху меняет таблицу, поэтому слияние также должно меняться как числапередвигаться.

Я не очень старался, потому что просто не могу придумать, как сделать это автоматически.Я хочу, чтобы ячейки сливались и сливались, потому что результаты изменятся.

Вот что я ожидаю:

При необходимости я могу показать, как работает свиток, чтобы сделать его визуально легчечтобы понять.

Answer 1

Это тот, который я использую.

Sub MergeSame()
    Dim rng As Range
    Dim First As Range
    Dim Last As Range

    Set rng = Selection

    If rng.Rows.Count > 1 Then Exit Sub

    For i = 1 To rng.Columns.Count + 1
        If rng.Cells(1, i).Value <> PreviousValue Then
            If Not (First Is Nothing) Then
                Set Last = rng.Cells(1, i - 1)
                Range(First, Last).Merge
            End If
            Set First = rng.Cells(1, i)
            PreviousValue = rng.Cells(1, i).Value
        Else
            rng.Cells(1, i).Clear
        End If

        rng.Cells(1, i).HorizontalAlignment = xlCenter

    Next i

End Sub

Answer 2

Спасибо вам обоим!

Вы помогли мне в создании моего собственного решения.

Он состоит из МНОГО (более 350 строк) из ifs и elses ...: P

Но это работает!

Answer 3

Вы можете попробовать:

Option Explicit

Sub test()

    Dim LastColumn As Long, StartPoint As Long, EndPoint As Long, i As Long, y As Long

    With ThisWorkbook.Worksheets("Sheet1")

        'Find the last column of row 1
         LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

        'Set StartPoint
        StartPoint = 1

        'Loop row 1
        For i = 1 To LastColumn

            If i = StartPoint Then

                For y = i + 1 To LastColumn

                    If .Cells(1, i).Value <> .Cells(1, y).Value Then

                        EndPoint = y - 1
                        Exit For

                    End If

                Next y

                Application.DisplayAlerts = False

                    With .Range(.Cells(1, StartPoint), Cells(1, EndPoint))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With

                Application.DisplayAlerts = True

                StartPoint = y
                EndPoint = 0

            End If

        Next i

    End With

End Sub