Need a VBA for adding rows above text in column B based on the count value of item in column D

[pholo2505]

Hi Friends,


I'm a member of this forum for a long time and found many VBA codes that fit to my works; thank you very much.
Today, I need another VBA codes but I cannot find it


I need VBA to add the total 20 rows above text in column B (FAC_7), accept for the first row (1063109), based on the count value of items in column D for the above item. So, the rows that need to be added will be the count number in D - 20.


For instance, for FAC_7 1066221, the items count in D will be 5, so the rows that need to be added above 1066221 is 20-5 =15 and for 1069205 is 20-3 = 17.

Thanks in advance,
Pon

Here is my sample data.

 

[pholo2505]

Here is data
A B C D E F G H I
ORDER_NO FAC_7 UCC_20_DIGIT UPC QTY DUNS_NUMBER SUPPLIER CRC FRC
0083798794 1063109 00008379879401063109 019585218830 33 103492930 5112010 3596203 2600096
019585218847 33 103492930 5112010 3596206 2600096
019585218892 33 103492930 5112010 3596205 2600096
019585218915 33 103492930 5112010 3596211 2600096
019585218694 34 103492930 5112010 3629677 2600096
0083798794 1066221 00008379879401066221 019585218694 32 103492930 5112010 3629677 7418288
019585218830 33 103492930 5112010 3596203 7418288
019585218915 33 103492930 5112010 3596211 7418288
0083798794 1069205 00008379879401069205 019585218694 34 103492930 5112010 3629677 4300216
019585218830 34 103492930 5112010 3596203 4300216
019585218847 34 103492930 5112010 3596206 4300216
019585218892 34 103492930 5112010 3596205 4300216
019585218915 34 103492930 5112010 3596211 4300216

Pon

 

[DanteAmor]

Try this
Note: Assume that in column G you have blank cells

Sub test()
    Dim counter()
    Dim r As Range, wa As Range
    Dim f As Long, m As Long, i As Long
    
    Set r = Range("G2:G" & Range("A" & Rows.Count).End(xlUp).Row)
    ReDim counter(r.SpecialCells(xlCellTypeBlanks).Areas.Count, 1)
    For Each wa In r.SpecialCells(xlCellTypeBlanks).Areas
        m = m + 1
        counter(m, 0) = 18 - wa.Count
        counter(m, 1) = wa.Rows.Count + wa.Cells(1, 1).Row
    Next
    For i = m To 1 Step -1
        f = counter(i, 1)
        Rows(f & ":" & f + counter(i, 0)).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
    Next
End Sub

 

[pholo2505]

Thanks Dante for the code. I modify it a little bit to fit my need and it work just fine - thanks again.

Pon

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.