VBA code for deleting "FALSE" functions

[BigBill7]

Hello I have been working on creating a Macro for work and have gotten decently deep into it. I have created several small macros that plan on adding to my master macro in the end. However right now I am stuck in the "deleting_not_true" macro where I am trying to delete anything in column S that comes back as False but I am not sure what the VBA code to achieve this would be? The best I can do is referencing a set range of cells after filtering the data for False, but that data will change once the new master data is added.

My second question will have to do with Macro "Autofilling" which simply autofills down to a certain cell but I need to add in a variable for it autofill down to however much data could be in the table at that time since it will change depending on what is in the master data. I am not familiar with the VBA code to achieve these objectives.28056

[Paul_Hossler]

Play around with these




Sub Autofilling()
Dim r As Range
Dim iLastRow As Long

With ActiveSheet
iLastRow = .Range("N1").End(xlDown).Row

Set r = .Range("Q2")
r.AutoFill Destination:=r.Resize(iLastRow - 1, 1)

Set r = .Range("R2")
r.AutoFill Destination:=r.Resize(iLastRow - 1, 1)

Set r = .Range("S2")
r.AutoFill Destination:=r.Resize(iLastRow - 1, 1)
End With

End Sub
Sub deleting_not_true()
Dim r1 As Range, r2 As Range, r As Range
Dim i As Long

With ActiveSheet
Set r1 = .Cells(1, 19)
Set r2 = .Cells(ActiveSheet.Rows.Count, 19).End(xlUp)
Set r = Range(r1, r2)

'when deleting it's important to start at the bottom
For i = r.Rows.Count To 2 Step -1
If IsError(r.Cells(i, 1).Value) Then
.Rows(i).EntireRow.Delete
ElseIf .Cells(i, 1).Value = False Then
.Rows(i).EntireRow.Delete
End If
Next i

.Columns("Q:S").Delete Shift:=xlToLeft
End With
End Sub

[p45cal]

I think you have a problem with the filtering in the Mutual_fund_fees macro;
You would lose values >100 and <101 with this filtering:
.AutoFilter Field:=14, Criteria1:="<=100"
.AutoFilter Field:=14, Criteria1:=">=101", Operator:=xlAnd, Criteria2:="<=1000"
Your sample data has no such values, as it happens.

You will lose values >1000 and <1001 with this:
.AutoFilter Field:=14, Criteria1:=">=101", Operator:=xlAnd, Criteria2:="<=1000"
.AutoFilter Field:=14, Criteria1:=">=1001", Operator:=xlAnd, Criteria2:="<=3000"
You have 2 such values: 1000.52 on row 2315 and 1000.11 or row 7423 which never appear on your newly created sheets.

You might want to use filter criteria more like this (depending on exactly how you want to split the data):

.AutoFilter Field:=14, Criteria1:="<=100"
.AutoFilter Field:=14, Criteria1:=">100", Operator:=xlAnd, Criteria2:="<=1000"
.AutoFilter Field:=14, Criteria1:=">1000", Operator:=xlAnd, Criteria2:="<=3000"

Also it could be a bit more robust to use
Set wsMaster = Sheets("Master")
instead of:
Set wsMaster = ActiveSheet
in case the active sheet isn't the right sheet when you start your macro.

As regards the three other macros which add the formula, autofill and delete rows, it's probably better to combine these three operations in one macro because you'll be using the usedrange of the sheet to determine where the formulae get put.
Thus:
Sub FormulaeAddandDeleteRows(sht)
'find extent of data on the fees sheet and create formula refs to be used later:
With Sheets("Fees")
Set rngFees = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
End With
ColmAAddress = rngFees.Columns(1).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmCAddress = rngFees.Columns(3).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmDAddress = rngFees.Columns(4).Address(ReferenceStyle:=xlR1C1, external:=True)
'find extent of data on the current sheet:
With sht
Set myRng = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
'Column Q,R & S formulae insert (you could do all this in one column with a longer formula):
Intersect(myRng.EntireRow, .Range("Q:Q")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmCAddress & ")"
Intersect(myRng.EntireRow, .Range("R:R")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmDAddress & ")"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]=0,RC[-1]=0)"
'filter for FALSE:
.UsedRange.AutoFilter Field:=19, Criteria1:="FALSE"
On Error Resume Next
myRng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
.ShowAllData
'.Range("Q:S").Delete 'if you want.
End With
End Sub

Call this at the bottom of the Mutual_fund_fees macro like this:

For Each sht In Sheets(Array("100 and below", "101 to 1000", "1001 to 3000"))
FormulaeAddandDeleteRows sht
Next sht
You may want to Dim sht as Worksheet at the top.

It was difficult to test because you omitted column H values from the Master sheet. Perhaps attach a workbook with that data included?

All that said, you could use Power Query to do all this processing. I'll prepare something with that tomorrow sometime (for which a new attachment from you would be welcome).

[snb]

Sub M_snb()
Range("Q2:S2").AutoFill Range("Q2:S2").Resize(Cells(1).CurrentRegion.Rows.Count - 1)
End Sub

If S2 ='TRUE"


Sub M_snb()
Rows(1).Copy
Columns(19).ColumnDifferences(Cells(2, 19)).EntireRow.Delete
Rows(1).Insert
End Sub

[BigBill7]

Thanks for the help with the first Macro I had not thought of that when looking over it.
In terms of the extra data i can give you to test it I can upload another file with some dummy security numbers that should help for any testing that you may need.

[p45cal]

In the attached, which has column H populated with your most recent attachment's dummy security nos., run your macro to add the 3 new sheets.
To update the sheets with the Power Queries in (the tab names all start PQ…) either right-click on each table individually and choose Refresh, or, refresh all at once by going to the Data tab of the ribbon, and clicking Refresh all in the Queries & Connections section.
I get the same sets of results in Power Query as your macro gets.

[BigBill7]

I'm getting an error 424 in the code here when trying to run any idea why? it worked before so I'm not sure what's wrong


'copy overWith rData
.AutoFilter Field:=14, Criteria1:="<=100"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("100 and below").Cells(1, 1)

.AutoFilter Field:=14, Criteria1:=">100", Operator:=xlAnd, Criteria2:="<=1000"
'.AutoFilter Field:=14, Criteria1:=">=101", Operator:=xlAnd, Criteria2:="<=1000"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("101 to 1000").Cells(1, 1)

[p45cal]

1. Does the attachment in msg#6 work without error?
2. You are starting this macro with the active sheet being the Master sheet? (If a blank sheet is the active sheet you will get this error). My earlier comment:
Also it could be a bit more robust to use
Set wsMaster = Sheets("Master")
instead of:
Set wsMaster = ActiveSheetwould be important here.
3. I need to see at least your whole code for this macro (preferably the workbook it's failing on).
4. What's changed?
5. In your last message you quote code as:

'copy overWith rData
In your actual code these are on separate lines as in:

'copy over
With rDataYes?

[BigBill7]

1: No the macro does not run without error

2: the error occurs in the .AutoFilter Field:=14, Criteria1:="<=100" part of the code
'Option Explicit

Sub Mutual_fund_fees()
Dim wsMaster As Worksheet
Dim rData As Range

Application.ScreenUpdating = False

'set Master - assumed to be active sheet
Set wsMaster = ActiveSheet
Set rData = wsMaster.Cells(1, 1).CurrentRegion
If wsMaster.AutoFilterMode Then wsMaster.AutoFilterMode = False

'delete old ones
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("100 and below").Delete
Worksheets("101 to 1000").Delete
Worksheets("1001 to 3000").Delete
Application.DisplayAlerts = True
On Error GoTo 0


'add new ones
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "100 and below"
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "101 to 1000"
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "1001 to 3000"


'copy over
With rData
.AutoFilter Field:=14, Criteria1:="<=100"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("100 and below").Cells(1, 1)

.AutoFilter Field:=14, Criteria1:=">100", Operator:=xlAnd, Criteria2:="<=1000"
'.AutoFilter Field:=14, Criteria1:=">=101", Operator:=xlAnd, Criteria2:="<=1000"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("101 to 1000").Cells(1, 1)



.AutoFilter Field:=14, Criteria1:=">1000", Operator:=xlAnd, Criteria2:="<=3000"
'.AutoFilter Field:=14, Criteria1:=">=1001", Operator:=xlAnd, Criteria2:="<=3000"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("1001 to 3000").Cells(1, 1)
End With



If wsMaster.AutoFilterMode Then wsMaster.AutoFilterMode = False

'format
Call FormatSheet("100 and below")
Call FormatSheet("101 to 1000")
Call FormatSheet("1001 to 3000")


For Each sht In Sheets(Array("100 and below", "101 to 1000", "1001 to 3000"))
FormulaeAddandDeleteRows sht
Next sht


wsMaster.Select

Application.ScreenUpdating = True
End Sub
Private Sub FormatSheet(s As String)
With Worksheets(s)
.Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With

.Cells(1, 1).CurrentRegion.Columns.ColumnWidth = 100
.Cells(1, 1).CurrentRegion.Columns.AutoFit
End With
End Sub


Sub FormulaeAddandDeleteRows(sht)
'find extent of data on the fees sheet and create formula refs to be used later:
With Sheets("Fees")
Set rngFees = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
End With
ColmAAddress = rngFees.Columns(1).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmCAddress = rngFees.Columns(3).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmDAddress = rngFees.Columns(4).Address(ReferenceStyle:=xlR1C1, external:=True)
'find extent of data on the current sheet:
With sht
Set myRng = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
'Column Q,R & S formulae insert (you could do all this in one column with a longer formula):
Intersect(myRng.EntireRow, .Range("Q:Q")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmCAddress & ")"
Intersect(myRng.EntireRow, .Range("R:R")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmDAddress & ")"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]=0,RC[-1]=0)"
'filter for FALSE:
.UsedRange.AutoFilter Field:=19, Criteria1:="FALSE"
On Error Resume Next
myRng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
.ShowAllData
'.Range("Q:S").Delete 'if you want.
End With
End Sub

3: I don't believe anything has changed I opened the file attempted to F8 through the Macro to watch it
4: yes i think i copied it wrong so i tried a new way and took out any source formatting

[snb]

Lost your spectacles ?

http://www.vbaexpress.com/forum/showthread.php?68510-VBA-code-for-deleting-quot-FALSE-quot-functions&p=407838&viewfull=1#post407838

[p45cal]

If the file I attached doesn't run properly, when it's run 'out of the box' when the Master sheet is the active sheet (it's fine here) Then what version of Excel are you using and is it on a Mac or a PC?

[BigBill7]

ok I don't think I had the "Master" tab as the active sheet in the beginning. What is some code I cold add to Have the macro start on master sheet?

[p45cal]

3rd time lucky:
Also it could be a bit more robust to use
Set wsMaster = Sheets("Master")
instead of:
Set wsMaster = ActiveSheet
in case the active sheet isn't the right sheet when you start your macro.

[BigBill7]

Sorry snb been working with alot of code lately see what works best, this also helps me I'll let you know if i have any further questions on your code or what is part of my next steps.

[BigBill7]

Thank you for the help so far I really appreciate it!
For the next part of this project I'm working was one of the equations that was used in the "0 to 100" tab needs to be changed slightly for "101 to 1000" and "1001 to 3000"

all I need to change is this part of the code for these different tabs
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]=0,RC[-1]=0)"

"101 to 1000"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]>0,RC[-1]=0)"

"1001 to 3000"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]>0,RC[-1]>0)"

I know your code is dependent on going back and doing the same thing in each sheet so I'm not sure how to code it correctly to do what I need.

[p45cal]

Sub FormulaeAddandDeleteRows(sht)
'find extent of data on the fees sheet and create formula refs to be used later:
With Sheets("Fees")
Set rngFees = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
End With
ColmAAddress = rngFees.Columns(1).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmCAddress = rngFees.Columns(3).Address(ReferenceStyle:=xlR1C1, external:=True)
ColmDAddress = rngFees.Columns(4).Address(ReferenceStyle:=xlR1C1, external:=True)
'find extent of data on the current sheet:
With sht
Set myRng = Intersect(.UsedRange, .UsedRange.Offset(1)) 'databody - excludes headers.
'Column Q,R & S formulae insert (you could do all this in one column with a longer formula):
Intersect(myRng.EntireRow, .Range("Q:Q")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmCAddress & ")"
Intersect(myRng.EntireRow, .Range("R:R")).FormulaR1C1 = "=XLOOKUP(RC8," & ColmAAddress & "," & ColmDAddress & ")"
Select Case sht.Name
Case "101 to 1000"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]>0,RC[-1]=0)"
Case "1001 to 3000"
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]>0,RC[-1]>0)"
Case Else
Intersect(myRng.EntireRow, .Range("S:S")).FormulaR1C1 = "=AND(RC[-2]=0,RC[-1]=0)"
End Select

'filter for FALSE:
.UsedRange.AutoFilter Field:=19, Criteria1:="FALSE"
On Error Resume Next
myRng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
.ShowAllData
'.Range("Q:S").Delete 'if you want.
End With
End Sub

[BigBill7]

thank you for the help everyone I will change the thread to solved.