Creating multiple records

Hello

I have an excel spread sheet with data and a number. I need a formula to repeat the data to the amount of the number and also one column counts. As an example

WS Carrier Route Number
C001 4
C002 3
C003 2

Result

WS Carrier Route Number
1 C001 4
2 C001 4
3 C001 4
4 C001 4
1 C002 3
2 C002 3
3 C002 3
1 C003 2
2 C003 2

I am not sure if this is possible. I am not an advanced user of Excel.
Thanks for any help.

Hello,

Where do you want the new columns to appear? On another sheet?

Another sheet would be fine, it could also be on the original sheet in different columns.

put this code in a module then run: ExtrapolateVals

Sub ExtrapolateVals()
Dim col As New Collection, colNum As New Collection
Dim vWord, vPrev
Dim iNum As Integer, i As Integer, j As Integer

Range("A2").Select
 
 While (ActiveCell.Value) <> ""
     vWord = ActiveCell.Value
     iNum = ActiveCell.Offset(0, 1).Value
     colNum.Add iNum
     For i = 1 To iNum
        col.Add vWord
     Next
     
    ActiveCell.Offset(1, 0).Select
 Wend
 
   'print results
Range("D2").Select
For i = 1 To col.Count
    ActiveCell.Value = col(i)
    If ActiveCell.Value <> vPrev Then j = j + 1
    ActiveCell.Offset(0, 1).Value = colNum(j)
    
    vPrev = ActiveCell.Value
    ActiveCell.Offset(1, 0).Select
Next

Set col = Nothing
Set colNum = Nothing
End Sub

Here's an 'ExpandData' subroutine. Change input and output range parameters as required.

ExpandData.xlsm

Sub Expand_Click()
    Dim Sht As Excel.Worksheet
    Set Sht = ThisWorkbook.Worksheets("Sheet1")
    ExpandData Sht.Range("B3:C5"), Sht.Range("B10")
End Sub

Public Sub ExpandData(SourceRng As Excel.Range, TargetCell As Excel.Range)
    Dim Sht As Excel.Worksheet
    Dim Arr As Variant
    Dim i As Long, j As Long
    Dim r As Long, c As Long
    r = TargetCell.Row
    c = TargetCell.Column
    Set Sht = SourceRng.Worksheet
    Arr = SourceRng.Value
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        For j = 1 To Arr(i, 2)
            Sht.Cells(r, c + 0).Value = j
            Sht.Cells(r, c + 1).Value = Arr(i, 1)
            Sht.Cells(r, c + 2).Value = Arr(i, 2)
            r = r + 1
        Next j
    Next i
End Sub