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

 

[Ombir]

Moss, Assuming you have data in Sheet1 and Columns A:H, here is the revised code that should solve your problem.

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, nsp1 As Variant, nsp2 As Variant

Set ws = Sheets("Sheet1")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row

Set rng = ws.Range("C2:C" & lr)

Application.ScreenUpdating = False

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

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