insert row under a s selected cell and merge a cells

[anell370]

HI
Sorry I'm not familiar with VBA but I need this for my project I need to create VBA button with a code to insert a row under a random selected cell "let's say D" and then merge each of the cellS before it ",C,B,A" with it the new cell inserted under it; for example C2 with C3, B2 with B3 ....keeping the selected one unmegred

THANKS

 

[tj4242]

The horizontal and vertical cell centering should be done before. And it does some crazy things if you are on a cell that has already been merged.

Sub Button1_Click()

    Dim activeC As Long                                                 'The column of the active cell
    Dim col As Long                                                     'a counter
    Dim rng As Range                                                    'range is needed to insert below
    
    activeC = ActiveCell.Column                                         'remember the column with the active cell

    Set rng = ActiveCell.Offset(1, 0)                                   'set up the range
    rng.EntireRow.Select                                                'select that entire row
    Selection.Insert shift:=xlDown                                      'insert below
    
    col = 1                                                             'starting at column A
    While col <= ActiveSheet.UsedRange.Columns.Count                    'go through all columns until done
        If col <> activeC Then                                          'is the current column the one that was active.  If it is do not merge it
            Range(Cells(activeR, col), Cells(activeR + 1, col)).Merge   'merge the cell and the one below it
        End If
        col = col + 1                                                   'move to the next column
    Wend
    
End Sub

 

[anell370]

The horizontal and vertical cell centering should be done before. And it does some crazy things if you are on a cell that has already been merged.

Sub Button1_Click()

    Dim activeC As Long                                                 'The column of the active cell
    Dim col As Long                                                     'a counter
    Dim rng As Range                                                    'range is needed to insert below
   
    activeC = ActiveCell.Column                                         'remember the column with the active cell

    Set rng = ActiveCell.Offset(1, 0)                                   'set up the range
    rng.EntireRow.Select                                                'select that entire row
    Selection.Insert shift:=xlDown                                      'insert below
   
    col = 1                                                             'starting at column A
    While col <= ActiveSheet.UsedRange.Columns.Count                    'go through all columns until done
        If col <> activeC Then                                          'is the current column the one that was active.  If it is do not merge it
            Range(Cells(activeR, col), Cells(activeR + 1, col)).Merge   'merge the cell and the one below it
        End If
        col = col + 1                                                   'move to the next column
    Wend
   
End Sub

Hello,
Thanks a lot for replying but the code doesn't work corractly, it doesn't merge cells it just add a row below, i don't understade why.
thanks

 

[mumps]

Try:

Sub MergeCells()
    Application.ScreenUpdating = False
    Dim x As Long
    Range("A" & ActiveCell.Row + 1).Insert
    For x = 1 To ActiveCell.Column - 1
        Cells(ActiveCell.Row + 1, x).Resize(2).Merge
    Next x
    Application.ScreenUpdating = True
End Sub