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

Coyotex3

Active Member
Joined
Dec 12, 2021
Messages
496
Office Version
  1. 365
Platform
  1. Windows
Here is the beginning file.

1640210832972.png


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

1640210975441.png


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.
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
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.
 
Upvote 0
See if this does what you want:

VBA Code:
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
 
Upvote 0
Solution
See if this does what you want:

VBA Code:
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!!!
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
VBA Code:
If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert

The Rows(X) there refers to one row

VBA Code:
        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
 
Upvote 0
VBA Code:
If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert

The Rows(X) there refers to one row

VBA Code:
        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!!
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top