使用 vba 取消合并和粘贴单元格

Question

我遇到了将报告处理成有用的结构化 Excel 模型的问题。

我的问题是此报告中的单元格已合并，现在我想取消合并它们以更轻松地处理信息。

我尝试使用宏记录器记录一些东西，但我不确定如何在工作表中的每个单元格上自动执行它。

我想让输出看起来像这样：

这是我录制的部分：

Sub Macro1()
    Range("A2:A3").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A3")
    Range("A2:A3").Select
End Sub

有什么建议可以重写这个宏来自动进行合并和粘贴吗？

感谢您的回复！

更新

我尝试使用选择，但是，我目前面临不知道如何获取下一个单元格的问题：

Sub split()
'
'Dim C As Double
'Dim R As Double
Dim Rng As Range

'select cells
Set Rng = Selection

'C = Rng
'R = 10
For Each cell In Rng
'starts in row 2 and A -> cell 2,1 is the first cell or A2
cell.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    'Cells(R + 1, C) = Cells(R, C)
    If cell.Value = "" Then MsgBox ("Finished splitting and copying!"): End
 '   If C = 7 Then C = 0: R = R + 2
Next cell

End Sub

Answer 1

   Sub Macro1()

    NbRows = Sheets("Feuil1").UsedRange.Rows.Count - 1
    NbCols = 9 ' If it doesn't change

   Range("A2:I11").Copy Destination:= _
        Range("K2")
   Range("K:S").MergeCells = False ' remove merge

    For i = 2 To NbRows ' Number of rows
        For j = 11 To NbCols + NbCols ' Number of cols
            If Cells(i, j) = "" Then
                Cells(i, j) = Cells(i - 1, j).Value
            End If
        Next j
    Next i
End Sub

我的代码将第一个表中的数据复制粘贴到单元格“K2”（如您的示例中所示）。然后，您删除将留下一些空白的合并。你想要做的是如果 cells(i , 1) 为空，那么你只需使用上面的数据 (cells(i-1, 1))

Answer 2

如果您要更改的数据位于 a 到 g 列，并且您从第 2 行开始并假设所有单元格都不为空

试试这个代码：

Sub split()
'
Dim C As Double
Dim R As Double

C = 1
R = 2
For C = 1 To 7

Cells(R, C).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Cells(R + 1, C) = Cells(R, C)
    If Cells(R, C).Value = "" Then MsgBox ("PROJECT ENDED"): End
    If C = 7 Then C = 0: R = R + 2
    Next C

    End Sub

请在运行宏之前保存您的数据。您无法撤消。