Outline numbering & blanks between cells

[dancingdata]

Hello,,

I am trying to create an outline numbering list from a data table which look like below:

[TABLE="width: 173"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]# of Criteria[/TD]
[TD]Numbering Category[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1.1[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1.2[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1.3[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]2.1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Result to be as follow:

4 1.1 1.1.1
4 1.1 1.1.2
4 1.1 1.1.3
4 1.1 1.1.4
3 1.2 1.2.1
3 1.2 1.2.2
3 1.2 1.2.3..etc

Can you help with a VBA code that can automate this process? Basically I need the VBA to insert new cells based on the number of criteria then generate the numbering for each numbering category.

Appreciate your support.

 

[Beyond_avarice]

Sub dancingdata()

Dim lRow As Long
Dim criteria As Long

lRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lRow To 1 Step -1

    criteria = Cells(i, 1).Value - 1
    
    Range(Cells(i, 1).Offset(1), Cells(i, 1).Offset(criteria)).EntireRow.Insert
       
    Cells(i, 1).Offset(0, 2).Value = Cells(i, 1).Offset(0, 1).Value & ".1"
        
    ActiveSheet.Range(Cells(i, 1), Cells(i, 3)).AutoFill (ActiveSheet.Range(Cells(i, 1), Cells(i, 3).Offset(criteria)))
        

Next i

End Sub

 

[dancingdata]

Thank you so much..It works perfectly on the given data. @Beyond_avarice

However, when I tried to use on the full data set I have it does not give the same results. Please refer to excel sheet in the link after applied the code

Dancingdata.xlsx - Google Drive

 

[Beyond_avarice]

It's because your actual data is "text" and not numbers. Does this have to remain as a text or can it be converted to a number?

 

[dancingdata]

No does not matter for me whether its a number or a text.. BTW, I tried to figure out the problem and its seems the code does not handle the numbering when the repetition is equal to one.. am I right?

Example:

[TABLE="width: 192"]
<colgroup><col width="64" style="width:48pt"> <col width="64" style="width:48pt"> <col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="class: xl65, width: 64"]2[/TD]
[TD="class: xl65, width: 64"]2.1[/TD]
[TD="width: 64"][/TD]
[/TR]
[TR]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]2.1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]3.1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"][/TD]
[TD="class: xl65"][/TD]
[TD="align: right"]0.1[/TD]
[/TR]
[TR]
[TD="class: xl65"][/TD]
[TD="class: xl65"][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]3.2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]3.3[/TD]
[TD]3.3.1[/TD]
[/TR]
[TR]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]3.3[/TD]
[TD]3.3.2[/TD]
[/TR]
</tbody>[/TABLE]

 

[Beyond_avarice]

Yes. I didn't account for 1 as criteria of whether to insert no rows. The following should address that.

Sub dancingdata()
Dim lRow As Long
Dim criteria As Long
Dim rFill As String
Dim rFill2 As String

lRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lRow To 1 Step -1

        If Cells(i, 1).Value - 1 >= 1 Then
                 criteria = Cells(i, 1).Value - 1
                 Range(Cells(i, 1).Offset(1), Cells(i, 1).Offset(criteria)).EntireRow.Insert
            
                 Cells(i, 1).Offset(0, 2).Value = Cells(i, 1).Offset(0, 1).Value & ".1"
                 
                 Range(Cells(i, 1).Offset(1), Cells(i, 2).Offset(criteria)).Value = Range(Cells(i, 1), Cells(i, 2)).Value
                
                 rFill = Cells(i, 3).Address
                 rFill2 = Cells(i, 3).Offset(criteria).Address
                 ActiveSheet.Range(Cells(i, 3).Address).AutoFill (ActiveSheet.Range(rFill, rFill2))
                 
           Else:
                Cells(i, 1).Offset(0, 2).Value = Cells(i, 1).Offset(0, 1).Value & ".1"
        End If
Next i

End Sub

 

[dancingdata]

Perfect! Thanks so much for your help dear