VBA Объединение столбцов в Excel

Question

Я пытаюсь написать простую вещь, которая объединит ячейки в Excel с одной и той же информацией. То, что я до сих пор получил, это то, что следует:

Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Set rngMerge = Range("B2:B1000") 'Set the range limits here
    Set rngMerge2 = Range("C2:C1000")

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 = False
    Application.ScreenUpdating = True


    For Each cell In rngMerge2
        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 = False
    Application.ScreenUpdating = True

End Sub

Итак, проблема, с которой я сталкиваюсь, разделена на две проблемы. Сначала я пытаюсь заставить это работать для столбцов A - AK, но, как вы можете видеть выше, я не знаю, как объединить это, не просто сделав это. повторить то же самое 30 раз. Есть ли другой способ сгруппировать его.

Кроме того, когда я назначаю диапазон диапазону («AF2: AF1000») и диапазону («AG2: AG1000»), это дает преимущество во всех сбоях. Я надеялся, что вы все могли бы помочь направить меня в правильном направлении.

Answer 1

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

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

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
    Set wks = Sheets("Sheet1")

    'To run this code across the entire "used part" of the worksheet, use this:
    Set mergeRange = wks.UsedRange
    'If you want to specify a range, you can do this:
    'Set mergeRange = wks.Range("A2:AK1000")

    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
                'In that case, the following will return the first cell in the merge area
                Set previousCell = cell.Offset(-1).MergeArea(1)

                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

---

Если вы хотите запустить этот код в нескольких диапазонах, вы можете изолировать код, который выполняет слияния в пределах диапазона, в свою собственную Sub процедуру:

Sub MergeCellsInRange(mergeRange As Range)
    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                Set previousCell = cell.Offset(-1).MergeArea(1)
                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

и вызовите его несколько раз из вашей основной процедуры:

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    Set wks = Sheets("Sheet1")

    MergeRange wks.Range("A2:U1000")
    MergeRange wks.Range("AA2:AK1000")
End Sub

---

Ссылки:

объектная модель Excel

• Global Свойство Sheets , Коллекция Sheets
• Объект листа
  • UsedRange свойство
• Диапазон объекта
  • Клетки собственности
  • Рядный объект
  • свойство смещения
  • MergeArea свойство
  • Значение свойства

1067 * VBA * For Each ... In конструкция IsEmpty функция Dim выписка Set выписка Sub выписка

Answer 2

Похоже, что вы выполняете ту же процедуру на rngMerge и rngMerge2, и что они имеют одинаковый размер.

Я предлагаю следующее, где вы просто перебираете столбцы, а затем - ячейки в каждом столбце:

Option Explicit
Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Dim rngFull As Range

    Set rngFull = Range("B2:AK1000")
    For Each rngMerge In rngFull.Columns
        For Each cell In rngMerge.Cells
            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
                Range(cell, cell.Offset(1, 0)).Merge
                'Add formatting statements as desired
            End If
        Next cell
    Next rngMerge

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
End Sub

ПРИМЕЧАНИЕ Как написано, это будет обрабатывать только дубликаты. Если у вас триплеты или больше, будут объединены только пары из двух.

Answer 3

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

Performance

1000 выглядит как произвольная строка: Range("B2:B1000"). Этот диапазон должен быть обрезан для соответствия данным.

Лучше объединить все ячейки для объединения и объединить их за одну операцию.

Application.DisplayAlerts не нужно устанавливать в True. Он будет сброшен после завершения подпрограммы.

---

Public Sub MergeCells()
    Dim Column As Range
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        For Each Column In .Columns("A:K")
            Set Column = Intersect(.UsedRange, Column)
            If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Sub MergeEqualValueCellsInColumn(Target As Range)
    Application.DisplayAlerts = False
    Dim cell As Range, rMerge As Range
    For Each cell In Target
        If cell.Value <> "" Then
            If rMerge Is Nothing Then
                Set rMerge = cell
            Else
                If rMerge.Cells(1).Value = cell.Value Then
                    Set rMerge = Union(cell, rMerge)
                Else
                    rMerge.Merge
                    Set rMerge = cell
                End If
            End If
        End If
    Next
    If Not rMerge Is Nothing Then rMerge.Merge
End Sub

Answer 4

Вы продолжаете изменять ячейки в rngMerge, но не определяете их до повторного использования. Скорее всего, это сработает лучше, если вы начнете снизу и будете работать, поскольку ситуация похожа на вставку или удаление строк.

Option Explicit

Private Sub MergeCells()

    Dim i As Long, c As Long, col As Variant

    Application.DisplayAlerts = False
    'Application.ScreenUpdating = false

    col = Array("B", "C", "AF", "AG")

    For c = LBound(col) To UBound(col)
        For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
            If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
                Cells(i, col(c)).Resize(2, 1).Merge
                Cells(i, col(c)).HorizontalAlignment = xlCenter
                Cells(i, col(c)).VerticalAlignment = xlCenter
            End If
        Next i
    Next c

    Application.DisplayAlerts = True
    'Application.ScreenUpdating = True
End Sub

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

Я также заметил закрытую природу подпроцедуры, и я предполагаю, что она находится в закрытом листе кода рабочей таблицы (щелчок правой кнопкой мыши на вкладке имени, Просмотреть код). Если код должен выполняться на нескольких рабочих листах, он принадлежит общедоступной кодовой таблице модуля (в VBE используется Вставка, Модуль), и в ячейки должны быть добавлены соответствующие ссылки на родительские рабочие листы.