Macro to get data in the below format

[Rev T]

I have data in the below format -

Col A1

Col A2

Col A3

Col A4

Col A5

Col A6

Col A7

Col A8

Col A9

Col A10

Col A11

Col A12

Col A13

Col A14

Col A15

Col A16

Col A17

Col A18

A

B

C

1,2,3,4,5,6,7,8

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

I need it to be this way -

Col A1

Col A2

Col A3

Col A4

Col A5

Col A6

Col A7

Col A8

Col A9

Col A10

Col A11

Col A12

Col A13

Col A14

Col A15

Col A16

Col A17

Col A18

A

B

C

1

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

2

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

3

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

4

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

5

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

6

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

7

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

A

B

C

8

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

Can someone help me out on this, thanks!

 

[Joe4]

Welcome to the Board!

So, is your value in column "A4" really column D on your worksheet?
The columns typically go in A, B, C, D, etc order, and rows go in 1,2,3,4, order.

What cell does the first line of data start in?
Is there a title row, so it is in cell A2, or is it in A1?

 

[Rev T]

So, is your value in column "A4" really column D on your worksheet? - Yes
What cell does the first line of data start in? - A2
Is there a title row, so it is in cell A2, or is it in A1? - Yes, there's a title row and it's in A1

 

[Joe4]

One last question I forgot to ask.
Is there always just one single row of data that you need to do this too, or might there be multiple rows that need to be expanded like this?

 

[Rev T]

There are multiple rows and it can be anywhere between 2 and 100 values separated by a comma in column D

 

[Joe4]

A bit of a "brute force" method, but it works:

Sub MyInsertRows()

    Dim lr As Long
    Dim r As Long
    Dim arr() As String
    Dim nr As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
'   Find last row in column D with data
    lr = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through all rows backwards
    For r = lr To 2 Step -1
'       Get value from column D and split
        arr = Split(Cells(r, "D"), ",")
'       See if we need to insert any rows
        nr = UBound(arr)
        If nr > 0 Then
'           Insert new rows
            Rows(r + 1 & ":" & r + nr).Insert
'           Copy row info to new rows
            Rows(r).Copy Rows(r + 1 & ":" & r + nr)
'           Populate column D
            For i = LBound(arr) To UBound(arr)
                Cells(r + i, "D") = arr(i)
            Next i
        End If
    Next r

    Application.ScreenUpdating = True
    
End Sub

 

[Rev T]

Joe4,​

It worked
Thanks a ton!

 

[Joe4]

You are welcome.
Glad I was able to help!

 

[Peter_SSs]

@Joe4 @Rev T
I would suggest one small change and that is to write arr to the worksheet all at once instead of a cell at a time.

For i = LBound(arr) To UBound(arr)
    Cells(r + i, "D") = arr(i)
Next i
Cells(r, "D").Resize(nr + 1).Value = Application.Transpose(arr)

 

[Rev T]

@Joe4 @Peter_SSs

Thanks once again.

If we were to name the Macro or Process, what'd we name it? My heading is a bit generic!