Excel VBA to filter and use IF/Then statements

[rachelm920]

I am attempting to filter an excel spreadsheet and use IF/Then statements.
I have searched this site (and google) high and low and cannot find a solution.
Basically what I need to do is filter all items with a quantity of <-24000 or =-1 Then if the quantity does equal -1 I need it to filter a different column searching for a specific item with that quantity.
I've tried copying all items that have the quantity <-24000 into a new spreadsheet, but when I try to go back to the original and then filter out the specific item code, I receive errors.
I've tried running a for then statement and inputting the filter within it, and that doesn't work either. Right now what I have is the copy/paste idea. At this point I really don't care what method I use, I'd just like the end result. Here's what I currently have:

        Dim Iss As Workbook
        Dim Super As Workbook
        Dim IssSheet As Worksheet
        Dim SupSheet As Worksheet
  
      
       'Supermarket Sheet Issues (These are for the <-24000 this portion works fine, and successfully copys/pastes the data into a new spreadsheet named "Supermarket today's date". Done is a file path I have at the beginning of the code this is a HUGE macro LOL)
        ActiveWorkbook.ActiveSheet.Range("A1:F1").AutoFilter
        ActiveWorkbook.ActiveSheet.Range("A1:F1").AutoFilter Field:=4, Criteria1:="<-24000" 
        Set Iss = ActiveWorkbook
        Set IssSheet = Iss.Sheets("Sheet1")
        Set Super = Workbooks.Add
            With Super
                Set SupSheet = Super.Sheets("Sheet1")
                .SaveAs Done & "Supermarket" & " " & Format(Date, "mmddyyyy") & ".xlsx", FileFormat _
                :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
                False, CreateBackup:=False
        
                    IssSheet.Range("A1:F999").Copy
            
                    SupSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
                    Transpose:=False
            End With
        ActiveWorkbook.Close
'This is where the errors start


        Iss.Close
        Workbooks.Open Iss ' This line is highlighted in yellow and says "Run-time error 424 object required" I am pretty sure it cannot find the "Iss" file I setup above.
        Set Iss = ActiveWorkbook
        With Iss
            Set IssSheet = Iss.Sheets("Sheet1")

I am pretty sure the problem is that it cannot locate the file I defined as Iss above. I can't set it to a direct file, because it changes daily (i.e. Issues_01192015.xlsx is today's file name and tomorrow will be 01202015 etc.)

Any assistance with this is greatly appreciated.

 

[rachelm920]

I've also attempted this

 ActiveWorkbook.ActiveSheet.Range("A1:F1").AutoFilter
        ActiveWorkbook.ActiveSheet.Range("A1:F1").AutoFilter Field:=4, Criteria1:="<-24000" , Operator:=xlOr, Criteria2:="-1" 
'The above filters my range correctly but when I add this:
ActiveWorkbook.ActiveSheet.Range("A1:F1").AutoFilter Field:=3, Criteria:="56625"

I get a run time error 1004 with this one Application-defined or object defined error
Any assistance with this is greatly appreciated.

 

[rachelm920]

Wanted to provide my own solution to this, in case anyone else is ever trying to accomplish something similar. New day, new ideas
I changed some wording to protect the innocent (haha)

        Dim My_Range As Range
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim FilterCriteria As String
        Dim CCount As Long
        Dim WSNew As Worksheet
        Dim sheetName As String
        Dim rng As Range
        Dim DestSh As Worksheet[INDENT]'Filter out item 12345 first[/INDENT]
        Set My_Range = Range("A1:F" & LastRow(ActiveSheet))
        My_Range.Parent.Select[INDENT]If ActiveWorkbook.ProtectStructure = True Or My_Range.Parent.ProtectContents = True Then[/INDENT]
[INDENT=2]MsgBox "Sorry, not working when the workbook or worksheet is protected", vbOKOnly, "Copy to new worksheet"[/INDENT]
[INDENT]End If[/INDENT]
[INDENT=2]With Application[/INDENT]
[INDENT=3]CalcMode = .Calculation[/INDENT]
[INDENT=3].Calculation = xlCalculationManual[/INDENT]
[INDENT=3].ScreenUpdating = False[/INDENT]
[INDENT=3].EnableEvents = False[/INDENT]
[INDENT=2]End With[/INDENT]
[INDENT]ViewMode = ActiveWindow.View[/INDENT]
[INDENT]ActiveWindow.View = xlNormalView[/INDENT]
[INDENT]ActiveSheet.DisplayPageBreaks = False[/INDENT]
        
        'Remove Auto Filter
        My_Range.Parent.AutoFilterMode = False
        
        'Add the filter for item 12345
        My_Range.AutoFilter Field:=3, Criteria1:="=12345"
        
        'Check if there are not more then 8192 areas(limit of areas that Excel can copy)[INDENT]CCount = 0[/INDENT]
[INDENT=2]On Error Resume Next[/INDENT]
[INDENT=3]CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count[/INDENT]
[INDENT=4]On Error GoTo 0[/INDENT]
[INDENT=3]If CCount = 0 Then[/INDENT]
[INDENT=4]MsgBox "There are more than 8192 areas:" _[/INDENT]
[INDENT=4]& vbNewLine & "It is not possible to copy the visible data." _[/INDENT]
[INDENT=4]& vbNewLine & "Tip: Sort your data before you use this macro.", _[/INDENT]
[INDENT=4]vbOKOnly, "Copy to worksheet"[/INDENT]
[INDENT=3]Else[/INDENT]
[INDENT=4]'Add a new Worksheet[/INDENT]
[INDENT=4]Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))[/INDENT]
[INDENT=4]sheetName = "Special"[/INDENT]
[INDENT=5]On Error Resume Next[/INDENT]
[INDENT=6]WSNew.Name = sheetName
If Err.Number > 0 Then[/INDENT]
[INDENT=7]MsgBox "Change the name of sheet : " & WSNew.Name & _[/INDENT]
[INDENT=7]" manually after the macro is ready. The sheet name" & _[/INDENT]
[INDENT=7]" you fill in already exists or you use characters" & _[/INDENT]
[INDENT=7]" that are not allowed in a sheet name."[/INDENT]
[INDENT=7]Err.Clear[/INDENT]
[INDENT=6]End If[/INDENT]
[INDENT=5]On Error GoTo 0[/INDENT]
[INDENT=4]'Copy/paste the visible data to the new worksheet[/INDENT]
[INDENT=4]My_Range.Parent.AutoFilter.Range.Copy[/INDENT]
[INDENT=5]With WSNew.Range("A1")[/INDENT]
[INDENT=6].PasteSpecial Paste:=8[/INDENT]
[INDENT=6].PasteSpecial xlPasteValues[/INDENT]
[INDENT=6].PasteSpecial xlPasteFormats[/INDENT]
[INDENT=6]Application.CutCopyMode = False[/INDENT]
[INDENT=6].Select[/INDENT]
[INDENT=5]End With[/INDENT]
[INDENT=5]With My_Range.Parent.AutoFilter.Range[/INDENT]
[INDENT=6]On Error Resume Next[/INDENT]
[INDENT=6]Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _[/INDENT]
[INDENT=6].SpecialCells(xlCellTypeVisible)[/INDENT]
[INDENT=6]On Error GoTo 0[/INDENT]
[INDENT=6]If Not rng Is Nothing Then rng.EntireRow.Delete[/INDENT]
[INDENT=5]End With[/INDENT]
[INDENT=6]End If[/INDENT]
[INDENT]'Close AutoFilter[/INDENT]
[INDENT]My_Range.Parent.AutoFilterMode = False[/INDENT]
[INDENT]'Restore ScreenUpdating, Calculation, EnableEvents, ....[/INDENT]
[INDENT]My_Range.Parent.Select[/INDENT]
[INDENT]ActiveWindow.View = ViewMode[/INDENT]
[INDENT=2]If Not WSNew Is Nothing Then WSNew.Select[/INDENT]
[INDENT=2]With Application[/INDENT]
[INDENT=3].ScreenUpdating = True[/INDENT]
[INDENT=3].EnableEvents = True[/INDENT]
[INDENT=3].Calculation = CalcMode[/INDENT]
[INDENT=2]End With[/INDENT]
                
        'Go back to the original sheet
        ActiveWorkbook.Sheets("Sheet1").Activate
    
        
        'Filter out the items <-24,000
        Set My_Range = Range("A1:F" & LastRow(ActiveSheet))
        My_Range.Parent.Select
     
        'Set the destination sheet to Special
        Set DestSh = Sheets("Special")
     
        'Filter out all items with more than 24,000
        My_Range.AutoFilter Field:=4, Criteria1:="<-24000"
      
        'Check if there are not more then 8192 areas(limit of areas that Excel can copy)[INDENT]CCount = 0[/INDENT]
[INDENT]On Error Resume Next[/INDENT]
[INDENT=2]CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count[/INDENT]
[INDENT=2]On Error GoTo 0[/INDENT]
[INDENT=3]If CCount = 0 Then[/INDENT]
[INDENT=4]MsgBox "There are more than 8192 areas:" _[/INDENT]
[INDENT=4]& vbNewLine & "It is not possible to copy the visible data." _[/INDENT]
[INDENT=4]& vbNewLine & "Tip: Sort your data before you use this macro.", _[/INDENT]
[INDENT=4]vbOKOnly, "Copy to worksheet"[/INDENT]
[INDENT=3]Else[/INDENT]
[INDENT=3]'Copy the visible data and use PasteSpecial to paste to the Destsh[/INDENT]
[INDENT=3]With My_Range.Parent.AutoFilter.Range[/INDENT]
[INDENT=4]On Error Resume Next[/INDENT]
[INDENT=4]' Set rng to the visible cells in My_Range without the header row[/INDENT]
[INDENT=4]Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _[/INDENT]
[INDENT=4].SpecialCells(xlCellTypeVisible)[/INDENT]
[INDENT=4]On Error GoTo 0[/INDENT]
[INDENT=5]If Not rng Is Nothing Then[/INDENT]
[INDENT=6]'Copy and paste the cells into DestSh below the existing data[/INDENT]
[INDENT=6]rng.Copy[/INDENT]
[INDENT=6]With DestSh.Range("A" & LastRow(DestSh) + 1)[/INDENT]
[INDENT=7].PasteSpecial Paste:=8[/INDENT]
[INDENT=7].PasteSpecial xlPasteValues[/INDENT]
[INDENT=7].PasteSpecial xlPasteFormats[/INDENT]
[INDENT=7]Application.CutCopyMode = False[/INDENT]
[INDENT=6]End With[/INDENT]
[INDENT=6]'Delete the rows in the My_Range.Parent worksheet[/INDENT]
[INDENT=6]rng.EntireRow.Delete[/INDENT]
[INDENT=5]End If[/INDENT]
[INDENT=3]End With[/INDENT]
[INDENT=3]End If[/INDENT]
[INDENT]
[/INDENT]

        'Close AutoFilter
        My_Range.Parent.AutoFilterMode = False
        
        'Restore ScreenUpdating, Calculation, EnableEvents, ....
        ActiveWindow.View = ViewMode
        Application.Goto DestSh.Range("A1")
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
                .Calculation = CalcMode
            End With
            
        'Go back to the original sheet
        ActiveWorkbook.Sheets("Sheet1").Activate
    
        'Rename the original sheet to "Others"
        ActiveWorkbook.ActiveSheet.Name = "Others"
        
        'Change the header on the Others Worksheet to Others Spreadsheet 
        ActiveWorkbook.ActiveSheet.PageSetup.CenterHeader = "&""Arial Black""&16&A &F"
                
        'Fix the Rows & Columns in the Others sheet
        ActiveWorkbook.ActiveSheet.Columns.AutoFit
        ActiveWorkbook.ActiveSheet.Rows.AutoFit
               
                
        'Switch to the Special Sheet
        ActiveWorkbook.Sheets("Special").Activate
        
        'Change the header on the Special Worksheet to Special Spreadsheet
        ActiveWorkbook.ActiveSheet.PageSetup.CenterHeader = "&""Arial Black""&16&A &F"
        
        'Add the page numbers to the footer of the Special worksheet
        ActiveWorkbook.ActiveSheet.PageSetup.CenterFooter = "Page &P of &N"
        
        'Sort the Special sheet by Date (column A) then by time (column B)
        Dim lr As Long
            With ActiveWorkbook.ActiveSheet
                lr = .Cells(Rows.Count, "A").End(xlUp).Row
                .Range("A2:F" & lr).Sort Key1:=.Range("A2"), order1:=1, key2:=.Range("B2"), order2:=1
                .Range("A2").Select
                .Activate
            End With
            
        
        'Fix the Rows & Columns in the Special Sheet
        ActiveWorkbook.ActiveSheet.Columns.AutoFit
        ActiveWorkbook.ActiveSheet.Rows.AutoFit
        
        'Print the entire workbook
         For Q = 0 To 15
            CurNePrint = Format(Q, "00")
            On Error Resume Next
            Application.ActivePrinter = "\\printerpath" & CurNePrint & ":"
            Next Q
        ActiveWorkbook.PrintOut
        
        'Save & Close
        ActiveWorkbook.SaveAs Done & ActiveWorkbook.Name
        Kill MyWorkbook
        ActiveWorkbook.Close

BTW I got the code from here