Excel- shift multiple data cell down and insert rows below

Question

I have a Excel 2007 sheet containing 1K records with 10+ columns. The problem is that, One cell contains multiple data which i need to move down into each cell and along with it, I need to insert new rows as shifting down the data disrupts the rest of the rows and overlaps. Is their a VBA code or macro process that does that. Please Help.

Here's the excel sheet.

Category | Desciption       | Sizes      | Price
------   | ------
car      | Car Description  |  123  - M  | $20
                               1245 - XL | $50
                               1243 - XXL| $55
Car2     | Car2 Description |  123  - M  | $20
                               1245 - XL | $50
                               1243 - XXL| $55

I hope its clear what I want to achieve. SIzes Column data are on ONE cell and I need to shift these down while inserting rows so as not to disturb the rest of data below.

Many Thanks. Haroon

user3598756 user3598756 · Accepted Answer · 2016-07-23T08:54:25

you can try and adapt (see comments) this code:

Option Explicit

Sub main()
    Dim iRow As Long, nRows As Long, nData As Long
    Dim arr As Variant

    With Worksheets("data").Columns("C") '<--| assuming "Sizes" are in column "C"
        nRows = .Cells(.Rows.Count, 1).End(xlUp).row '<--| get column "C" last non empty row
        For iRow = nRows To 2 Step -1 '<--| loop through column "C" rows from the last one upwards
            With .Cells(iRow) '<--| reference column "C" current cell
                arr = Split(.Value, vbLf) '<--| try and split cell content into an array with "linefeed" character as delimeter
                nData = UBound(arr) + 1 '<--| count array items (Split generates 0-based array, so a 1-element array upperbound is 0)
                If nData > 1 Then '<--| if there are more than 1 ...
                    .EntireRow.Offset(1).Resize(nData - 1).Insert '<--| insert rows beneath current cell
                    .Resize(nData).Value = Application.Transpose(arr) '<--| fill current cell and new ones beneath it with array values (you have to transpose it, since array is a 1-row array while you're writing into a 1-column range)
                    .Offset(, 1).Resize(nData).Value = Application.Transpose(Split(.Offset(, 1).Value, vbLf)) '<--| do the same filling with adjacent cell
                End If
            End With
        Next iRow
    End With
End Sub

Excel- shift multiple data cell down and insert rows below

1 Answers