 # 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.
Microsoft ExcelMicrosoft Applications Last Comment
jnsimex

8/22/2022 - Mon
Patrick Matthews

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

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
SANTABABY

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
Zack Barresse

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

@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