VBA - Add X amount of Rows Based On Value of Cell

[moss84]

Hello All - This is my first time posting so please let me know if I am in the right spot.

I am looking for some vba code that will add X amount of rows based on the value of one of my cells. Unfortunately when a deliverable is being released in multiple states my source data dumps all of this information into a single cell (e.g. State (AZ, AK, NM). Basically, I want to write a macro that will generate a new row for each state. All other attributes for the data are identical for each state. Please see below for my current data structure and my desired output. Thanks for the help!

Current Data Structure
Deliverable Date State
Release Pilot 2/1/2015 AZ, NM, WI
Code Freeze 2/1/2015 WI, MI

Desired Output
Deliverable Date State
Release Pilot 2/1/2015 AZ
Release Pilot 2/1/2015 NM
Release Pilot 2/1/2015 WI
Code Freeze 2/1/2015 WI
Code Freeze 2/1/2015 MI

 

[MickG]

Assuming you data is in 3 columns then try this:-
NB:- This code will alter those 3 columns

[COLOR="Navy"]Sub[/COLOR] MG08Jan34
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray(), c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To 3, 1 To 1)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Offset(, 2).Value, ", ")
        ReDim Preserve Ray(1 To 3, 1 To UBound(Ray, 2) + UBound(Sp) + 1)
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                c = c + 1
                Ray(1, c) = Dn.Value
                Ray(2, c) = CDbl(DateValue(Dn.Offset(, 1).Value))
                Ray(3, c) = Sp(n)
            [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
Range("A2").Resize(c, 3).Value = Application.Transpose(Ray)
Range("B2").Resize(c).NumberFormat = "0"
Range("B2").Resize(c).NumberFormat = "dd/mm/yyy"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Max1616]

.

 

[Richard U]

Something like this should work

Sub test_stuff()
Dim s_Hold, sRight, sLeft, splitter() As String
Dim i As Integer

s_Hold = Cells(MyRow, MyColumn)
i = InStr(sm, ",")
sRight = Right(sm, Len(sm) - InStrRev(sm, " ", i))
sLeft = Left(sm, InStrRev(sm, " ", i))
splitter = Split(sRight, ",")

For ictr = 0 To UBound(splitter)
     Sheets("MySheet").Cells(ictr + 1, MyColumn) = sLeft & splitter(ictr)
Next ictr

End Sub

 

[oldbrewer]

Deliverable Date

State

Release Pilot

02/01/2015

AZ, NM, WI

Code Freeze

02/01/2015

WI, MI

Desired Output

Deliverable Date

State

Release Pilot

02/01/2015

AZ

Release Pilot

02/01/2015

NM

this macro pulls out the states

Release Pilot

02/01/2015

WI

Code Freeze

02/01/2015

WI

I am sorry I do not have time

Code Freeze

02/01/2015

MI

to get it to your format

Dim nn(5), state(20)

rownum = 20

For j = 2 To 3

For k = 1 To 100

If Mid(Cells(j, 3), k, 1) = "," Then mmm = k: GoTo 50

GoTo 100

50 tot = tot + 1

AZ

NM

WI

nn(tot) = mmm

WI

MI

100 Next k

nn(tot + 1) = nn(tot) + 4

For z = 1 To tot + 1

xxx = Mid(Cells(j, 3), nn(z) - 2, 2)

Cells(rownum, z) = xxx

Next z

nn(1) = ""

nn(2) = ""

tot = 0

rownum = rownum + 1

Next j

200 End Sub

<colgroup><col><col><col><col span="10"></colgroup><tbody>
</tbody>

 

[moss84]

Mick - Thank you so much, this is perfect. The data that I will eventually be using will have more than 3 columns...which parts of the string would I have to modify to adapt this to say 20 columns? I can keep the state column constant in the 3rd column but there will be additional data points. Thanks again,


Matt

 

[MickG]

Try something like this:-

[COLOR="Navy"]Sub[/COLOR] MG08Jan24
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray(), c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
'[COLOR="Green"][B]ReDim Ray(1 To 3, 1 To 1)[/B][/COLOR]


'[COLOR="Green"][B]for 20 columns:-[/B][/COLOR]
ReDim Ray(1 To 20, 1 To 1)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Offset(, 2).Value, ", ")
        '[COLOR="Green"][B]ReDim Preserve Ray(1 To 3, 1 To UBound(Ray, 2) + UBound(Sp) + 1)[/B][/COLOR]
        
        '[COLOR="Green"][B]for 20 columns:-[/B][/COLOR]
        ReDim Preserve Ray(1 To 20, 1 To UBound(Ray, 2) + UBound(Sp) + 1)
   
            [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                c = c + 1
                Ray(1, c) = Dn.Value
                Ray(2, c) = DateValue(Dn.Offset(, 1).Value)
                Ray(3, c) = Sp(n)
                Ray(4, c) = Dn.Offset(, 3)
                Ray(5, c) = Dn.Offset(, 4)
                Ray(6, c) = Dn.Offset(, 5)
                 '[COLOR="Green"][B]Repeat to 20, as below[/B][/COLOR]
                Ray(20, c) = Dn.Offset(, 19)
            [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn


'[COLOR="Green"][B]Range("A2").Resize(c, 3).Value = Application.Transpose(Ray)[/B][/COLOR]
'[COLOR="Green"][B]for 20 columns:-[/B][/COLOR]
Range("A2").Resize(c, 20).Value = Application.Transpose(Ray)
Range("B2").Resize(c).NumberFormat = "0"
Range("B2").Resize(c).NumberFormat = "dd/mm/yyy"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Ombir]

Moss, Here is another alternative that will works for x number of rows:

Sub moss84()
Dim i As Long, j As Long, lr As Long, rins As Integer
Dim ws As Worksheet, rng As Range, nrng As Range
Dim sp As Variant, nsp As Variant

Set ws = Sheets("Sheet2")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("C2:C" & lr)

Application.ScreenUpdating = False

For Each Cell In rng
    j = j + Len(Cell) - Len(Replace(Cell.Text, ",", ""))
Next

Set nrng = Range("C2:C" & j + lr)
    
For Each Cell In nrng
    If InStr(Cell, ",") <> 0 Then
        sp = Split(Cell.Text, ", ")
        nsp = Range("A" & Cell.Row & ":B" & Cell.Row)
        rins = UBound(sp)
        Cell.Offset(1).Range("A1:A" & rins).Select
        Selection.EntireRow.Insert shift:=xlShiftDown
        Range("A" & Cell.Row & ":B" & Cell.Row).Resize(rins + 1) = nsp
        Range("C" & Cell.Row).Resize(rins + 1) = Application.Transpose(sp)
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[moss84]

Thanks Ombir - appreciate the code it works great. One thing that is not working is that the macro identifies the states and creates new records but it does not copy the data to the right of the state column. It does, however, repeat the data to the left of state column. Apologize for multiple request but Im not sure how to fix this.

Thanks, Matt!

 

[moss84]

To clarify, I have data in columns D:H that I want to be repeated for each state record that is split out from column C....if that makes sense?

Thanks again!

Thanks Ombir - appreciate the code it works great. One thing that is not working is that the macro identifies the states and creates new records but it does not copy the data to the right of the state column. It does, however, repeat the data to the left of state column. Apologize for multiple request but Im not sure how to fix this.

Thanks, Matt!