We help IT Professionals succeed at work.

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

on
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.
Comment
Watch Question

## View Solution Only

CERTIFIED EXPERT
Top Expert 2010

Commented:
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.

Commented:
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
Software Professional
CERTIFIED EXPERT

Commented:
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
CERTIFIED EXPERT

Commented:
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!

Commented:
@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
CERTIFIED EXPERT
Commented:
I see, your data isn't always constant and varies column to column whether it will have data or not.  In that case, maybe this will work for you instead...

``````Option Explicit

Sub InsertRows()
Dim WS As Worksheet
Dim rInsert As Range
Dim iRow As Long
Dim iLastRow As Long
Application.ScreenUpdating = False
Set WS = ActiveSheet 'change as desired
WS.Columns(3).Insert
iLastRow = WS.Range("A:B").Cells.Find(What:="*", After:=WS.Range("A1"), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rInsert = WS.Range("C1:C" & iLastRow)
rInsert.NumberFormat = "General"
rInsert.Formula = "=IF(TRIM(A1)="""",MID(TRIM(B1),2,1),MID(TRIM(A1),2,1))&""-""&IF(TRIM(B1)="""",MID(TRIM(A1),2,1),MID(TRIM(B1),2,1))"
For iRow = iLastRow - 1 To 1 Step -1
If WS.Cells(iRow, 3).Value <> WS.Cells(iRow + 1, 3).Value And WS.Cells(iRow + 1, 3).Value <> vbNullString Then
Debug.Print iRow
WS.Rows(iRow + 1).Insert
End If
Next iRow
WS.Columns(3).Delete
Application.ScreenUpdating = True
End Sub
``````

HTH

Regards,
Zack Barresse

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