Как убрать строки, а не столбцы

Question

введите описание изображения здесь У меня есть таблица, которая содержит объединенные ячейки как столбец, так и строки. Я хочу удалить строки «Only», оставив столбцы объединенными. Рассмотрим следующий фрагмент таблицы. На изображении прикреплено "Контракт

For y = 1 To lRow
        p = 1
        c = y
        d = 1
        z = lRow + y
        t = Cells(y, 1).Value
        For x = 1 To t
        Cells(z, p).Value = Cells(c, d).Value
        Cells(c, d).Select
    '      Debug.Print
        Selection.End(xlToRight).Select
        c = ActiveCell.Row
        d = ActiveCell.Column
              p = p + 1
        Next

        Next

Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
                .UnMerge
'                .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1 

End If
Next
End Sub

Answer 1

Неважно.Я решил проблему под рукой.Проводка, если это помогает другим.

Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
                .UnMerge
                .Formula = c.Formula
End With

For J = startrow To endrow
    Application.DisplayAlerts = False
    Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
    Application.DisplayAlerts = True
Next

End If Next End Sub

Answer 2

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

Sub Merge_unmerge()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim LastRow As Long
    Dim LastCol As Long
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)

    With ws
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    Set rng = ws.Range("A1:D" & LastRow)
    For Each cell In rng
        cell.UnMerge
    Next cell
    For i = 2 To LastRow
        If Range("A" & i) = "" Then
            Range("A" & i).Value = Range("A" & i - 1).Value
        End If
    Next i
    For i = 2 To LastRow
        If Range("D" & i) = "" Then
           Range("D" & i).Value = Range("D" & i - 1).Value
        End If
    Next i
    For i = 1 To LastRow Step 2
        Range("B" & i & ":C" & i).Merge
        Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
    Next i
End Sub