Объединение ячеек в различных диапазонах

Question

я следующее:



Я ожидаю следующее:

Я использую этот код:

Sub merge_cells() 

Application.DisplayAlerts = False 

Dim r As Integer 
Dim mRng As Range 
Dim rngArray(1 To 4) As Range 
r = Range("A65536").End(xlUp).Row 

For myRow = r To 2 Step -1 

    If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then 

     For cRow = (myRow - 1) To 1 Step -1 

      If Range("A" & myRow).Value <> Range("A" & cRow).Value Then 

       Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 0)) 
       Set rngArray(2) = Range("B" & myRow & ":B" & (cRow + 0)) 
       Set rngArray(3) = Range("C" & myRow & ":C" & (cRow + 0)) 
       Set rngArray(4) = Range("D" & myRow & ":D" & (cRow + 0)) 

       For i = 1 To 4 
        Set mRng = rngArray(i) 
        mRng.Merge 
        With mRng 
         .HorizontalAlignment = xlCenter 
         .VerticalAlignment = xlCenter 
         .WrapText = False 
         .Orientation = 90 
         .AddIndent = False 
         .IndentLevel = 0 
         .ShrinkToFit = False 
         .ReadingOrder = xlContext 
         .MergeCells = True 
        End With 

       Next i 

       myRow = cRow + 2 
       Exit For 
      End If 
     Next cRow 
    End If 
Next myRow 

Application.DisplayAlerts = True 

End Sub 

, что я получаю:

Вопрос:, как добиться этого?

Фактически в моих первоначальных данных первые три столбца имеют данные каждые 88 строк, начиная с строки 3, а столбец D должен объединяться каждые четыре строки.

Answer 1

Ваш код не различает разные столбцы каким-либо образом. Если вы знаете, сколько строк нужно объединить, вы можете просто искать ячейки, а затем выполнять слияние на основе номера столбца. Вот один такой подход, который использует пару массивов для отслеживания количества строк для объединения, а затем для форматирования.

Вам нужно будет изменить количество строк в определении массива. Похоже, вы хотите (87,87,87,3) на основе вашего редактирования. Я сделал (11,11,11,3), чтобы соответствовать вашему примеру. Это реальное решение для вашего кода; он использует номер Column, чтобы определить, сколько строк нужно объединить.

Я также просто ввел некоторые значения в электронную таблицу и использовал SpecialCells, чтобы получить только ячейки со значениями. Если ваши данные соответствуют вашему примеру, это работает отлично.

Редактировать включает в себя неотмешивающие ячейки сначала по запросу ОП.

Sub MergeAllBasedOnColumn() 

    Dim rng_cell As Range 
    Dim arr_rows As Variant 
    Dim arr_vert_format As Variant 

    'change these to the actual number of rows 
    'one number for each column A, B, C, D 
    arr_rows = Array(11, 11, 11, 3) 

    'change these if the formatting is different than example 
    arr_vert_format = Array(True, True, True, False) 

    'unmerge previously merged cells 
    Cells.UnMerge 

    'get the range of all cells, mine are all values 
    For Each rng_cell In Range("A:D").SpecialCells(xlCellTypeConstants) 

     'ignore the header row 
     If rng_cell.Row > 2 Then 

      'use column to get offset count 
      Dim rng_merge As Range 
      Set rng_merge = Range(rng_cell, rng_cell.Offset(arr_rows(rng_cell.Column - 1))) 

      'merge cells 
      rng_merge.Merge 

      'apply formatting 
      If arr_vert_format(rng_cell.Column - 1) Then 
       'format for the rotated text (columns A:C) 
       With rng_merge 
         .HorizontalAlignment = xlCenter 
         .VerticalAlignment = xlCenter 
         .WrapText = False 
         .Orientation = 90 
         .AddIndent = False 
         .IndentLevel = 0 
         .ShrinkToFit = False 
         .ReadingOrder = xlContext 
       End With 
      Else 
       'format for the other cells (column D) 
       With rng_merge 
         .HorizontalAlignment = xlCenter 
         .VerticalAlignment = xlCenter 
         .WrapText = False 
       End With 
      End If 
     End If 
    Next rng_cell 
End Sub 

Перед

После