Working on this for a few days. How would you guys improve on this looping code?

[Coyotex3]

Here is the beginning file.

Here is the code I'm using.

Sub CopyPayeeCode()
Dim Rng As Range
For Each Rng In Range("C8", Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
Rng.Offset(-1, -2).Resize(Rng.Count + 1, 2).FillDown
Next Rng
End Sub

Sub DeleteBlankRows()
Range("D6", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

Sub InsertRow5()

Rows(5).Insert
End Sub

Sub SortByD()
Range("A6").CurrentRegion.Sort Range("D6"), xlAscending, Range("A6"), , xlAscending, Header:=xlYes
End Sub

Sub InsertRowsAtValueChangeColumnB()
Dim X As Long, LastRow As Long
Const DataCol As String = "D"
Const StartRow = 3
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
Application.ScreenUpdating = False
For X = LastRow To StartRow + 1 Step -1
If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert
Next
Application.ScreenUpdating = True
End Sub
Sub DeleteRow5()

Rows(5).Delete
End Sub
Sub DeleteRow6()

Rows(6).Delete
End Sub
Sub Automation()
Call CopyPayeeCode
Call DeleteBlankRows
Call InsertRow5
Call SortByD
Call InsertRowsAtValueChangeColumnB
Call InsertRowsAtValueChangeColumnB
Call DeleteRow5
Call DeleteRow5
Call DeleteRow5
Call DeleteRow6
Call DeleteRow6
Call DeleteRow6
End Sub

Here is the final product

What I'm trying to do here is find a more efficient way sort, insert, and delete rows. I only know how to do it by repeating the code. When inserting the column with code "InsertRowsAtValueChangeColumnB" I would like for it to insert 3 rows, but my code is only inserting one row on the first go around, and upon repeating it a second time it inserts the extra rows.

I also don't know how to tell it to delete rows 5,6, and 7 therefore I'm just repeating the macros.

Any tips are welcome, very new to this but this is very interesting.

 

[Coyotex3]

A few of you guys helped out on my previous threads. I had to change those codes a bit as the data was exported differently.

 

[johnnyL]

See if this does what you want:

Sub CopyDeleteInsertSortInsertDelete()
'
    Dim X   As Long, LastRow    As Long
    Dim Rng As Range
'
'-----------------------------------------------------------------------------------------------------------------
'
'   CopyPayeeCode
    For Each Rng In Range("C8", Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
        Rng.Offset(-1, -2).Resize(Rng.Count + 1, 2).FillDown
    Next Rng
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteBlankRows
    Range("D6", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).EntireRow.Delete
'
'-----------------------------------------------------------------------------------------------------------------
'
'   InsertRow5
    Rows(5).Insert
'
'-----------------------------------------------------------------------------------------------------------------
'
'   SortByD
    Range("A6").CurrentRegion.Sort Range("D6"), xlAscending, Range("A6"), , xlAscending, Header:=xlYes
'
'-----------------------------------------------------------------------------------------------------------------
'
'   InsertRowsAtValueChangeColumnB                                                                                  ' Actually the code is checking column D ;)
    Const DataCol As String = "D"
    Const StartRow = 3
'
    LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
'
    Application.ScreenUpdating = False
'
    For X = LastRow To StartRow + 1 Step -1
        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Range(DataCol & X & ":" & DataCol & X + 2).EntireRow.Insert
    Next
'
    Application.ScreenUpdating = True
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteRow5
    Rows("5:8").EntireRow.Delete
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteRow6
    Rows("6:8").EntireRow.Delete
End Sub

 

[Coyotex3]

See if this does what you want:

Sub CopyDeleteInsertSortInsertDelete()
'
    Dim X   As Long, LastRow    As Long
    Dim Rng As Range
'
'-----------------------------------------------------------------------------------------------------------------
'
'   CopyPayeeCode
    For Each Rng In Range("C8", Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
        Rng.Offset(-1, -2).Resize(Rng.Count + 1, 2).FillDown
    Next Rng
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteBlankRows
    Range("D6", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).EntireRow.Delete
'
'-----------------------------------------------------------------------------------------------------------------
'
'   InsertRow5
    Rows(5).Insert
'
'-----------------------------------------------------------------------------------------------------------------
'
'   SortByD
    Range("A6").CurrentRegion.Sort Range("D6"), xlAscending, Range("A6"), , xlAscending, Header:=xlYes
'
'-----------------------------------------------------------------------------------------------------------------
'
'   InsertRowsAtValueChangeColumnB                                                                                  ' Actually the code is checking column D ;)
    Const DataCol As String = "D"
    Const StartRow = 3
'
    LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
'
    Application.ScreenUpdating = False
'
    For X = LastRow To StartRow + 1 Step -1
        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Range(DataCol & X & ":" & DataCol & X + 2).EntireRow.Insert
    Next
'
    Application.ScreenUpdating = True
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteRow5
    Rows("5:8").EntireRow.Delete
'
'-----------------------------------------------------------------------------------------------------------------
'
'   DeleteRow6
    Rows("6:8").EntireRow.Delete
End Sub

Thank you! I'm going to go look at the code carefully to see the differences. I may have a question or two. Thanks once again!!!

 

[johnnyL]

Glad to help @Coyotex3. The code I provided, basically eliminates all of the calls to separate subroutines by putting all of the codes into one subroutine. The other thing I did was eliminate your duplicated subroutine calls by combining what the end result would be of running them multiple times into one line for them. Ex. instead of multiple deletes or inserts, do them all at once.

 

[Coyotex3]

Glad to help @Coyotex3. The code I provided, basically eliminates all of the calls to separate subroutines by putting all of the codes into one subroutine. The other thing I did was eliminate your duplicated subroutine calls by combining what the end result would be of running them multiple times into one line for them. Ex. instead of multiple deletes or inserts, do them all at once.

Thank you for that explanation. Do you know why my code was only inserting one row instead of three, forcing me to run the code twice.

Sub InsertRowsAtValueChangeColumnB()
Dim X As Long, LastRow As Long
Const DataCol As String = "D"
Const StartRow = 3
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
Application.ScreenUpdating = False
For X = LastRow To StartRow + 1 Step -1
If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert
Next
Application.ScreenUpdating = True
End Sub

 

[johnnyL]

If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert

The Rows(X) there refers to one row

        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Range(DataCol & X & ":" & DataCol & X + 2).EntireRow.Insert

That line specifies a range of rows ... Range(DataCol & X & ":" & DataCol & X + 2) ... ie. Row(X) thru Row(X+2) ... 3 in total

 

[Coyotex3]

If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert

The Rows(X) there refers to one row

        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Range(DataCol & X & ":" & DataCol & X + 2).EntireRow.Insert

That line specifies a range of rows ... Range(DataCol & X & ":" & DataCol & X + 2) ... ie. Row(X) thru Row(X+2) ... 3 in total

Ah okay. Thank you. Your code is awesome!!

 

[johnnyL]

Glad to help @Coyotex3. My code and awesome are seldom included in the same sentence. After all, I only modified a bit of the code that you posted. I am happy that you are happy.