Addition to VBA code

[bopha99]

Hi everyone,

Thanks for your help in advance. This one should be pretty easy. I have the attached Excel file with the associated VBA code. If someone could add one last step to it so that at the end after the VBA code performs the main task that any value in column F that is less than 1.00, that row should be deleted. If the VBA code can then copy the output to a new book and have the create a copy box checked, that would be great. Thanks again for your help.3127331273

[Aussiebear]

You could try this by placing a "Call sDelete_Rows" just before End Sub in the existing Sub.


Sub sDelete_Rows()
‘Declaring the variable lRow as long to store the last row number
Dim lRow As Long
‘Declaring the variable iCntr as long to use in the For loop
Dim iCntr As Long
‘Assigning the last row value to the variable lRow
lRow = 100
‘Using for loop
‘We are checking the each cell value if it cell <1.00 (equals to zero value)
‘And deleting the row if true
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 6)=0 Then
Rows(iCntr).Delete
End If
Next
End Sub

[bopha99]

You could try this by placing a "Call sDelete_Rows" just before End Sub in the existing Sub.


Sub sDelete_Rows()
‘Declaring the variable lRow as long to store the last row number
Dim lRow As Long
‘Declaring the variable iCntr as long to use in the For loop
Dim iCntr As Long
‘Assigning the last row value to the variable lRow
lRow = 100
‘Using for loop
‘We are checking the each cell value if it cell <1.00 (equals to zero value)
‘And deleting the row if true
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 6)=0 Then
Rows(iCntr).Delete
End If
Next
End Sub



So would the code look like this? Or am I missing something? see below.


Sub test()
Dim a, s
With Workbooks.Open("G:\My Drive\Singular Research\Marketing\Lists\Shareholder List Master\Names to Delete Row.xlsx") '<-- change file path
a = .Sheets("Sheet1").[A1].CurrentRegion.Value
.Close False
End With
With ThisWorkbook.Sheets("Find Contacts Report").[A1].CurrentRegion
b = .Value
For Each s In a
For x = 1 To UBound(b)
If b(x, 2) Like "*" & s & "*" Then b(x, 2) = "#N/A"
Next
Next
.Columns(2) = Application.Index(b, Evaluate("row(1:" & UBound(b) & ")"), 2)
.AutoFilter 2, "#N/A"
.Offset(1).EntireRow.Delete
.AutoFilter
End With

Call sDelete_Rows
Sub sDelete_Rows()
‘Declaring the variable lRow as long to store the last row number
Dim lRow As Long
‘Declaring the variable iCntr as long to use in the For loop
Dim iCntr As Long
‘Assigning the last row value to the variable lRow
lRow = 100
‘Using for loop
‘We are checking the each cell value if it cell <1.00 (equals to zero value)
‘And deleting the row if true
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 6)=0 Then
Rows(iCntr).Delete
End If
Next
End Sub

[Aussiebear]

No.. Call the sDelete_Rows sub by inserting
Call sDelete_Rows after .Autofilter and before End Sub

[p45cal]

Try adding the last 3 lines of the snippet below:
.Columns(2) = Application.Index(b, Evaluate("row(1:" & UBound(b) & ")"), 2)
.AutoFilter 2, "#N/A"
.Offset(1).EntireRow.Delete
.AutoFilter
.AutoFilter 6, Criteria1:="<1"
.Offset(1).EntireRow.Delete
.AutoFilter

[bopha99]

No.. Call the sDelete_Rows sub by inserting
Call sDelete_Rows after .Autofilter and before End Sub

Unfortunately, I'm getting errors. can you enter in the code for me? sorry I dont know what I'm doing

[Aussiebear]

What errors are you getting? Once we can't see your workbook, and you haven't explained what the errors are or when you are receiving them, we are only guessing.

Have a look here as to how to call another Sub. https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/calling-sub-and-function-procedures Then stop for a minute and think about when the extra sub needs to be called.

[bopha99]

What errors are you getting? Once we can't see your workbook, and you haven't explained what the errors are or when you are receiving them, we are only guessing.

Have a look here as to how to call another Sub. https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/calling-sub-and-function-procedures Then stop for a minute and think about when the extra sub needs to be called.


I see what you are saying about the Sub. I am getting a syntax error on the line Sub sDelete_Rows(). I have attached my excel file so you can see. Thanks in advance for checking it over.

Sub test()


Dim a, s
With Workbooks.Open("G:\My Drive\Singular Research\Marketing\Lists\Shareholder List Master\Names to Delete Row.xlsx") '<-- change file path
a = .Sheets("Sheet1").[A1].CurrentRegion.Value
.Close False
End With


With ThisWorkbook.Sheets("Find Contacts Report").[A1].CurrentRegion
b = .Value
For Each s In a
For x = 1 To UBound(b)
If b(x, 2) Like "*" & s & "*" Then b(x, 2) = "#N/A"
Next
Next
.Columns(2) = Application.Index(b, Evaluate("row(1:" & UBound(b) & ")"), 2)
.AutoFilter 2, "#N/A"
.Offset(1).EntireRow.Delete
.AutoFilter
End Sub
Call sDelete_Rows
Sub sDelete_Rows()
‘Declaring the variable lRow as long to store the last row number
Dim lRow As Long
‘Declaring the variable iCntr as long to use in the For loop
Dim iCntr As Long
‘Assigning the last row value to the variable lRow
lRow = 100
‘Using for loop
‘We are checking the each cell value if it cell <1.00 (equals to zero value)
‘And deleting the row if true
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 6) = 0 Then
Rows(iCntr).Delete
End If
Next
End Sub

[Aussiebear]

You are completely missing the point regarding "calling a sub". It needs to be called from within the main sub.


Sub test()
Dim a, s
With Workbooks.Open("G:\My Drive\Singular Research\Marketing\Lists\Shareholder List Master\Names to Delete Row.xlsx") '<-- change file path
a = .Sheets("Sheet1").[A1].CurrentRegion.Value
.Close False
End With
With ThisWorkbook.Sheets("Find Contacts Report").[A1].CurrentRegion
b = .Value
For Each s In a
For x = 1 To UBound(b)
If b(x, 2) Like "*" & s & "*" Then b(x, 2) = "#N/A"
Next
Next
.Columns(2) = Application.Index(b, Evaluate("row(1:" & UBound(b) & ")"), 2)
.AutoFilter 2, "#N/A"
.Offset(1).EntireRow.Delete
.AutoFilter
Call sDelete_Rows '<---- After . Autofilter and before End Sub
End Sub

Sub sDelete_Rows()
‘Declaring the variable lRow as long to store the last row number
Dim lRow As Long
‘Declaring the variable iCntr as long to use in the For loop
Dim iCntr As Long
‘Assigning the last row value to the variable lRow
lRow = 100
‘Using for loop
‘We are checking the each cell value if it cell <1.00 (equals to zero value)
‘And deleting the row if true
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 6) = 0 Then
Rows(iCntr).Delete
End If
Next
End Sub

[Aussiebear]

Disregard the doubled code tags in the post above. There is something going on with the posting to the forum.

[bopha99]

Disregard the doubled code tags in the post above. There is something going on with the posting to the forum.

My friend told me to use ChatGPT and it wrote the code below that works amazingly well. See below:


Sub MainOptimized()
Dim wsTarget As Worksheet
Dim a As Variant, b As Variant
Dim s As Variant
Dim x As Long, lRow As Long
Dim calcSetting As Long

' Turn off screen updating and set calculation to manual
Application.ScreenUpdating = False
calcSetting = Application.Calculation
Application.Calculation = xlCalculationManual

' Open workbook and read data
With Workbooks.Open("G:\My Drive\Singular Research\Marketing\Lists\Shareholder List Master\Names to Delete Row.xlsx") ' <-- change file path
a = .Sheets("Sheet1").[A1].CurrentRegion.Value
.Close False
End With

' Set reference to target sheet
Set wsTarget = ThisWorkbook.Sheets("Find Contacts Report")

' Process data
With wsTarget.[A1].CurrentRegion
b = .Value
For Each s In a
For x = 1 To UBound(b)
If b(x, 2) Like "*" & s & "*" Then b(x, 2) = "#N/A"
Next x
Next s
.Columns(2).Value = Application.Index(b, Evaluate("row(1:" & UBound(b) & ")"), 2)
.AutoFilter 2, "#N/A"
.Offset(1).EntireRow.Delete
.AutoFilter
End With

' Delete rows based on column F condition
lRow = wsTarget.Cells(wsTarget.Rows.Count, 6).End(xlUp).Row
DeleteRowsLessThanOneOptimized wsTarget, lRow

' Copy output to a new workbook and save
wsTarget.Copy
With ActiveWorkbook
.SaveAs "Output.xlsx" ' <-- change path and filename as needed
.Close
End With

' Restore application settings
Application.Calculation = calcSetting
Application.ScreenUpdating = True

' Inform user of completion
MsgBox "Operation completed successfully!", vbInformation
End Sub


Sub DeleteRowsLessThanOneOptimized(ws As Worksheet, lRow As Long)
Dim deleteRange As Range
Dim iCntr As Long
For iCntr = lRow To 1 Step -1
If ws.Cells(iCntr, 6).Value < 1 Then
If deleteRange Is Nothing Then
Set deleteRange = ws.Rows(iCntr)
Else
Set deleteRange = Union(deleteRange, ws.Rows(iCntr))
End If
End If
Next iCntr
If Not deleteRange Is Nothing Then deleteRange.Delete
End Sub