CODEWITHSUNDEEP
vbaexcelexcel-2010
Carol.Kar
Carol.Kar

Reputation: 5345

Unmerge and paste cells down with vba

I am facing the problem to proecess a report I got into a useful structured excel model.

My problem is that cells in this report are merged and now I would like to unmerge them to process the information much easier.

I tried to record something using the macro recorder, but I am unsure how to automate it on every cell in the sheet.

I would like to let the output look like that:

enter image description here

This is the part I recorded:

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

Any suggestions how to rewrite this macro to do the merging and pasting automatically?

Appreciate your replies!

UPDATE

I tried to use the selection, however, I am currently facing the problem of not knowing how to get next cell:

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

Upvotes: 2

Views: 2066

Answers (2)

Hearner
Hearner

Reputation: 2729

   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

My code copy-paste the datas from the first table to the cell "K2" (as in your example). Then, you remove the merge that will left some blanks. What you want to do is if cells(i , 1) is empty, then you just use the data from above (cells(i-1, 1))

Upvotes: 1

Balinti
Balinti

Reputation: 1534

if the data you want to change is on columns a to g and your are starting from row 2 and assuming all of the cell are not empty

try this code:

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

Please save your data before running the macro. You cannot undo.

Upvotes: 1

Related Questions