Excel VBA macro from one cell to multiple cells

Question

This macro works if you apply to one cell at a time (or if you drag across multiple rows, will work on the row of the top-left-most cell). Is there a way I can further tweak it to get my macro to apply the changes to the rows of all selected cells so that the user can make changes to rows in bulk?

I recorded a macro that will split what exist as one row into 8 rows for the last columns J:Q My logic was to insert 7 rows above a selected cell (which exist below the cell that will be merged) and then merge the rows with the original existing row for columns A:I

This will give me one cell for A:I and 8 rows for J:Row End

*See macro below



Sub splitrowsandmerge()
'
' splitrowsandmerge Macro
' add 7 rows and merge 8 rows for first 9 columns
'
' Keyboard Shortcut: Ctrl+Shift+E
'
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
ActiveCell.Offset(-1, 0).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlLTR
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
ActiveCell.Offset(0, 1).Range("A1:A8").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
     .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
End Sub

Answer 1

I have made a few adjustments to make more sense of this code and make it much easier to read through. This doesn't answer your original question as I need a little more information to understand what you trying to do. But this should help myself and others read through your code easier.

I made a guess at what you were looking for and pasted some code that should work for you, if you want every column from A to I in the row you select to be merged with the 7 inserted rows below.

    Sub splitrowsandmerge()
'
' splitrowsandmerge Macro
' add 7 rows and merge 8 rows for first 9 columns
'
' Keyboard Shortcut: Ctrl+Shift+E
'

Dim RowArray() As Integer

check = 0

For Each cell In Selection
    If firstTime <> 1 Then
        ReDim RowArray(0) As Integer
        RowArray(0) = cell.Row
        firstTime = 1
    Else

        For i = LBound(RowArray) To UBound(RowArray)
            If RowArray(i) = cell.Row Then
                check = 1
                Exit For
            End If
        Next i

        If check <> 1 Then
            addOne = addOne + 1
            ReDim Preserve RowArray(addOne) As Integer
            RowArray(addOne) = cell.Row
        End If

        check = 0
    End If
Next cell

RowArray = BubbleSrt(RowArray, False)
For i = LBound(RowArray) To UBound(RowArray)

    startCell = RowArray(i)
    Rows(startCell + 1).EntireRow.Resize(7).Insert

    With Range(Cells(startCell, 1), Cells(startCell + 7, 9))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    For j = 1 To 9
        Range(Cells(startCell, j), Cells(startCell + 7, j)).Merge
    Next j
Next i

End Sub

Public Function BubbleSrt(ArrayIn, Ascending As Boolean)

Dim SrtTemp As Variant
Dim i As Long
Dim j As Long


If Ascending = True Then
    For i = LBound(ArrayIn) To UBound(ArrayIn)
         For j = i + 1 To UBound(ArrayIn)
             If ArrayIn(i) > ArrayIn(j) Then
                 SrtTemp = ArrayIn(j)
                 ArrayIn(j) = ArrayIn(i)
                 ArrayIn(i) = SrtTemp
             End If
         Next j
     Next i
Else
    For i = LBound(ArrayIn) To UBound(ArrayIn)
         For j = i + 1 To UBound(ArrayIn)
             If ArrayIn(i) < ArrayIn(j) Then
                 SrtTemp = ArrayIn(j)
                 ArrayIn(j) = ArrayIn(i)
                 ArrayIn(i) = SrtTemp
             End If
         Next j
     Next i
End If

BubbleSrt = ArrayIn

End Function