Link to home
Create AccountLog in
Avatar of jnsimex
jnsimex

asked on

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

Hi Everyone,

I have a spreadsheet that has the following account numbers in two columns:

42002-080             52002-080
42002-080             52002-080
42002-100             52002-100
                                 52002-110
42003-950             52003-950
                                 52005-904
43001-023      
                                53006-000
                                53006-061


The 4XXXX series represent Revenue and the 5XXXX series represent COS.

I am trying to insert a row for the subtotal based on the change in value for the second character in either column.

i.e In the example above, I would insert a row in between 43001-023 and 52000-904 because the account number has the number 2 as its second character instead of the number 3.
Avatar of Patrick Matthews
Patrick Matthews
Flag of United States of America image

You wrote:

i.e In the example above, I would insert a row in between 43001-023 and 52000-904 because the account number has the number 2 as its second character instead of the number 3.

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.
Avatar of jnsimex
jnsimex

ASKER

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!
Avatar of jnsimex

ASKER

@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
ASKER CERTIFIED SOLUTION
Avatar of Zack Barresse
Zack Barresse
Flag of United States of America image

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Avatar of jnsimex

ASKER

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