用vba取消并粘贴细胞

我面临的问题是如何处理一个有用的结构化Excel模型的报告。

我的问题是，这个报告中的单元格被合并，现在我想解散他们来处理信息更容易。

我试图使用macroslogging器logging一些东西，但我不确定如何在表单中的每个单元格上自动化它。

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

这是我logging的部分：

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 

任何build议如何重写这个macros做自动合并和粘贴？

感谢您的回复！

UPDATE

我试图使用这个select，但是，我目前面临着不知道如何获得下一个单元格的问题：

 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”（如你的例子）。 然后，您删除将留下一些空白的合并。 你想要做的是如果单元格（i，1）是空的，那么你只需要使用上面的数据（单元格（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 

运行macros之前请保存您的数据。 你不能撤消。