Excel VBA Macro to insert rows based on criteria's being met

You wrote:


Your sample data from the question has no entry for 52000-904.

Please post a sample file with sample input and the expected result given that sample input, along with a clearer description of what you are trying to do.

Sorry, I meant 52005-904

Basically, I am trying to creates ranges of account numbers that share the same 2nd character so I can subtotal them.

So all the 43xxx and 53xxxx accounts will be one range and all the 42xxx and 52xxx accounts will be anthor range etc.

Please see attached for the sample file
Book3.xlsx

Try using the following macro:

Sub InsertSubTotalRow()
Dim ContFlag As Boolean
Dim r As Long
Dim lastacc As String

    r = 1
    ContFlag = True
    lastacc = ""
   
    While ContFlag
        r = r + 1
        If Trim(Range("A" & r)) = "" And Trim(Range("B" & r)) = "" Then
            If Trim(Range("A" & r - 1)) = "" And Trim(Range("B" & r - 1)) = "" Then
                ContFlag = False
            Else
                lastacc = ""
            End If
        Else
            If Trim(Range("A" & r)) <> "" Then
                If lastacc <> "" And Trim(Left(Range("A" & r), 2)) <> lastacc Then
                    ActiveSheet.Rows(r).Insert Shift:=xlDown
                    lastacc = ""
                End If
                If lastacc = "" Then
                    lastacc = Left(Trim(Range("A" & r)), 2)
                End If
            End If
        End If
    Wend

End Sub

Hmm, while I don't understand your data structure at all (can't give advice, as we don't know your intentions or purpose), this might get you what you're looking for...


Sub InsertRows()
    Dim iLastRow As Long
    Dim iRow As Long
    Dim iAcctInt As Long
    iLastRow = Range("A:B").Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For iRow = iLastRow To 2 Step -1
        If Trim(Cells(iRow, 1).Value) <> vbNullString Then
            iAcctInt = Mid(Cells(iRow, 1).Value, 2, 1)
        End If
        If Trim(Cells(iRow, 2).Value) <> vbNullString Then
            If iAcctInt = 0 Then
                iAcctInt = Mid(Cells(iRow, 2).Value, 2, 1)
            End If
            If Mid(Cells(iRow, 2).Value, 2, 1) <> iAcctInt Then
                Rows(iRow + 1).Insert
                iAcctInt = 0
            End If
        End If
    Next iRow
End Sub


HTH

Regards,
Zack Barresse

Hiya Patrick!

@SantaBaby

When I run your macro on the full data, it works well but the insertion of the sub total row is off by 1 in a couple of ranges and dead on for other ranges.

I have uploaded the full data for you to see for yourself.
Book3.xlsx

Thank you Zack!..this macro worked like a champ