vba- Insert Raws in excel

Hello,
Can you please help with a code that Insert rows between cells (Column "C", "QA:"), Starting row 2.
if rows Between QA: and QA: is less than 18, then add rows at the end.
if Rows Between QA: and QA: more than 18, then delete rows at the end.

I have dynamic number of rows.
Please sample attached.
Thank you.
Sample.xlsx
W.E.BAsked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
Saqib Husain, SyedConnect With a Mentor EngineerCommented:
Sub qa2qa18()
    Dim lqa As Range, uqa As Range, xtrarows As Long
    Set uqa = Range("C:C").Find("QA:", Range("C1"), , xlWhole)
    Set lqa = uqa.Resize(Rows.Count - uqa.Row - 1).Find("QA:", uqa, , xlWhole)
    Do While lqa.Row <> uqa.Row
        xtrarows = lqa.Row - uqa.Row - 19
        Select Case xtrarows
            Case Is = 0
            Case Is > 0
                lqa.Offset(-xtrarows).Resize(xtrarows).EntireRow.Select
                Selection.Delete
            Case Is < 0
                lqa.Resize(-xtrarows).EntireRow.Select
                Selection.Insert
        End Select
        Set uqa = lqa
        Set lqa = uqa.Resize(Rows.Count - uqa.Row - 1).Find("QA:", uqa, , xlWhole)
    Loop
End Sub
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Please try this.....
Sub InsertRows()
Dim rng As Range
Dim n As Long
Application.ScreenUpdating = False
For Each rng In Range("C:C").SpecialCells(xlCellTypeConstants, 1).Areas    
    If rng.Cells(rng.Rows.Count) < 18 Then
        n = 18 - rng.Cells(rng.Rows.Count)
        rng.Cells(rng.Rows.Count + 1).Resize(n).EntireRow.Insert
    ElseIf rng.Cells(rng.Rows.Count) > 18 Then
        n = rng.Cells(rng.Rows.Count) - 18
        rng.Cells(rng.Rows.Count).Offset(-n + 1).Resize(n).EntireRow.Delete
    End If
Next rng
Application.ScreenUpdating = True
End Sub

Open in new window

0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
And if you want to fill the missing numbers as well, please try this....
Sub InsertRows()
Dim rng As Range
Dim n As Long, lr As Long
Application.ScreenUpdating = False
For Each rng In Range("C:C").SpecialCells(xlCellTypeConstants, 1).Areas
    rng.Cells(rng.Rows.Count).Select
    If rng.Cells(rng.Rows.Count) < 18 Then
        n = 18 - rng.Cells(rng.Rows.Count)
        rng.Cells(rng.Rows.Count + 1).Resize(n).EntireRow.Insert
    ElseIf rng.Cells(rng.Rows.Count) > 18 Then
        n = rng.Cells(rng.Rows.Count) - 18
        rng.Cells(rng.Rows.Count).Offset(-n + 1).Resize(n).EntireRow.Delete
    End If
Next rng
lr = Cells(Rows.Count, 3).End(xlUp).Row
Range("C2:C" & lr).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C+1"
Range("C2:C" & lr).Value = Range("C2:C" & lr).Value
Application.ScreenUpdating = True
End Sub

Open in new window

0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
Saqib Husain, SyedEngineerCommented:
Sub qa2qa18()
    Dim lqa As Range, uqa As Range, xtrarows As Long
    Set uqa = Range("C:C").Find("QA:", Range("C1"), , xlWhole)
    Set lqa = uqa.Offset(1).Resize(Rows.Count - uqa.Row).Find("QA:", uqa.Offset(1), , xlWhole)
    Do While Not lqa Is Nothing
        xtrarows = lqa.Row - uqa.Row - 19
        Select Case xtrarows
            Case Is = 0
            Case Is > 0
                lqa.Offset(-xtrarows).Resize(xtrarows).EntireRow.Select
                Selection.Delete
            Case Is < 0
                lqa.Resize(-xtrarows).EntireRow.Select
                Selection.Insert
        End Select
        Set uqa = lqa
        Set lqa = uqa.Offset(1).Resize(Rows.Count - uqa.Row).Find("QA:", uqa.Offset(1), , xlWhole)
    Loop
End Sub
0
 
W.E.BAuthor Commented:
Hi Subodh,
I'm getting error when trying the code.
Please sample atatched.
Note, the sequencing  I put on the original sample, was just to show the numbers of rows, (it wasn't meant to be there), sometimes I have data , some times empty cells in between QA:

Hi Saqib,
Your code is working, but, if I have QA: on consecutive rows, it doesn't add 18 rows in between.

Thank you.
Sample2.xlsx
0
 
W.E.BAuthor Commented:
Thank you very much.
0
All Courses

From novice to tech pro — start learning today.