Adding Rows using Macro

[sycodiz]

Please help. I have a sheet where everytime Column B shows 101, I need 6 lines inserted. Then I would like those 6 additional rows in B to say 101 and then column C to have the following shown below. Note, there are 437 lines in my sheet with "101" and there are actually over 8000 lines total. Any help would be greatly appreciated.

B C
101 101
101 102
101 103
101 106
101 107
101 108
101 110

 

[JackDanIce]

This assumes your data starts in A1 and the last row is defined by column B, the last column is defined by row 1, try:

Sub macro1()

    Dim x       As Long
    Dim y       As Long
    Dim z       As Long
    Dim i       As Long
    
    Dim arr()   As Variant
    Dim arrO()  As Variant
    Dim arrA()  As Variant
    
    x = Cells(rows.count, 2).End(xlUp).row
    y = Cells(1, Columns.count).End(xlToLeft).Column
    z = WorksheetFunction.CountIf(Cells(1, 2).Resize(x), 101) * 7
    arrA = Array(101, 102, 103, 106, 107, 108, 110)
    
    If z > 0 Then
    
        arr = Cells(1, 1).Resize(x, y).value
        ReDim arrO(LBound(arr, 1) To UBound(arr, 1) + z, LBound(arr, 2) To UBound(arr, 2))
        z = LBound(arrO, 1)
        
        For x = LBound(arr, 1) To UBound(arr, 1)
        
            For y = LBound(arr, 2) To UBound(arr, 2)
                arrO(z, y) = arr(x, y)
            Next y
            
            If arr(x, 2) = 101 Then
                For i = z To z + 6
                    arrO(i, 2) = 101
                    arrO(i, 3) = arrA(i - z)
                Next i
                z = i
            Else
                z = z + 1
            End If
            
        Next x
        
    End If
    
    Cells(1, 1).Resize(UBound(arrO, 1), UBound(arrO, 2)).value = arrO
    
    Erase arr
    Erase arrO
    Erase arrA

End Sub