VBA объединяет похожие ячейки

Question

Я хотел бы объединить похожие ячейки по столбцам, так как сейчас я использую этот макрос

Sub MergeSimilarCells()

    Set myRange = Range("A1:Z300")

CheckAgain:
    For Each cell In myRange
        If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(0, 1)).Merge
            cell.VerticalAlignment = xlCenter
            cell.HorizontalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

End Sub

Моя проблема с сотнями строк и 40-50 столбцами, это занимает вечность. Я почти уверен, что цикл For Loop может помочь мне в этом, но я недостаточно квалифицирован, чтобы понять это

Я знаю, что следующий код неверен, но я потерян

Sub SimilarCells()
  Set myRange = Range("A1:G4")
    Dim count As Integer

CheckAgain:
    count = 1

    For Each cell In myRange
        If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
            count = count + 1

        ElseIf cell.Value <> cell.Offset(0, 1).Value Then
            Range(cell, cell.Offset(0, -count)).Merge
        End If
    Next

End Sub

Вот что я хотел бы сделать

Answer 1

Sub MergeMe()    

    Dim wks As Worksheet: Set wks = Worksheets(1)
    Dim myRange As Range: Set myRange = wks.Range("B2:H5")
    Dim myCell As Range
    Dim myCell2 As Range

    Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
    Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
    Dim firstRow As Long: firstRow = myRange.Rows(1).row
    Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
    Dim column As Long
    Dim row As Long

    OnStart

    For column = lastColumn To firstColumn Step -1
        For row = lastRow To firstRow Step -1
            Set myCell = wks.Cells(row, column)
            Set myCell2 = myCell.Offset(0, -1)
            If myCell.Value = myCell2.Value Then
                With wks.Range(myCell, myCell2)
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
            End If
        Next row
    Next column

    OnEnd

End Sub

В этом коде немало хитростей:

• нам нужно получить первый и последний столбец и строку;
• тогда мы должны выполнить цикл изот последней ячейки (внизу справа) до первой (вверху слева);
• нам не следует вводить первый столбец, поскольку мы используем .Offset(0,-1) и сравниваем каждую ячейку с самой левой;
• причина всей операции в том, что по умолчанию значение объединенной ячейки сохраняется в ее левой верхней ячейке. Другие ячейки объединенной ячейки не имеют значения.
• Вот почему мы всегда сравниваем объединенные ячейки с их «левым» соседом;

Это OnEnd и OnStart, облегчающие операцию.

Public Sub OnEnd()

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    Application.StatusBar = False

End Sub

Public Sub OnStart()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    ActiveWindow.View = xlNormalView

End Sub

Answer 2

Только одно слияние на группу

ИЗМЕНЕНО, чтобы исправить - спасибо Витя за хедз-ап

Sub MergeEm()

    Dim rw As Range, i As Long, s As Long, v

    Range("C21:J33").Copy Range("C5:J17")  'for testing purposes: replace previous run

    Application.ScreenUpdating = False
    For Each rw In Range("C5:J17").Rows 'or wherever
        i = 1
        s = 1
        Do While i < (rw.Cells.Count)
            v = rw.Cells(i).Value
            'check for a run of same values
            Do While Len(v) > 0 And v = rw.Cells(i + s).Value
                s = s + 1
                If i + s > rw.Cells.Count Then Exit Do
            Loop
            'if s>1 then had a run: merge those ells
            If s > 1 Then
                Application.DisplayAlerts = False
                rw.Cells(i).Resize(1, s).Merge
                rw.Cells(i).HorizontalAlignment = xlCenter
                Application.DisplayAlerts = True
                i = i + s 'skip over the merged range
                s = 1     'reset s
            Else
                i = i + 1
            End If
        Loop
    Next rw
End Sub

Answer 3

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

Изменить, чтобы учесть столбец A и предотвратить появление первого столбца. ячейки для слияния с ячейками вне myRange:

Sub MergeSimilarCells()

Dim i As Long
Dim myCol As String


Set myRange = Range("K1:L30")

myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)

If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
    Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
        InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
        InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
    For i = myRange.Cells.Count To 1 Step -1
        If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
            Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
            myRange.Item(i).VerticalAlignment = xlCenter
            myRange.Item(i).HorizontalAlignment = xlCenter
        End If
    Next
End If

End Sub

Чтобы выяснить, почему myRange должен начинаться в столбце B: Offset(0, -1) любой ячейки в столбце A, возникнет ошибкапоскольку слева от A.

нет столбца.