vba code to add a filter to worksheets and copy data to new tab not working on second pass.

[mwalsh]

Hello, I am new to VBA coding and below is my code where I add a filter, filter the data and copy the data to a new worksheet and rename it. It works great the first time it is run but the 2nd time it can't find the "x" value. When I F8 through the code the variables are there except for the x value is = nothing.


Option Compare Database
Function Excel_Output2()

Dim db As DAO.Database
Set db = CurrentDb
Dim xlApp As Excel.Application
'_________Recordsets_________
Dim r01, r02 As DAO.Recordset
Dim rg As Range
Set r01 = db.OpenRecordset("Invoice")
Set r02 = db.OpenRecordset("Late_Fees")


Dim i%
Dim j%
'Create a variable for the file number

Dim strFileNoA As String
Dim strFileNoB As String

While Not r01.EOF

'get the fileNo of current record

strFileNoA = r01.Fields("FileID")
strFileNoB = r01.Fields("FileID")

j = 1
For i = 1 To r01.RecordCount


strFileNoB = strFileNoA
strFileNoA = r01.Fields("FileID")
If strFileNoA <> strFileNoB Then
j = 1
Else
j = j
End If
With r01
.Edit
.Fields("Line Number") = (j)
.Update
.MoveNext
End With
j = j + 1
Next i
Wend

'_________Paths_________
Dim strPath$, strSavePath$, strfilenm$
Dim source As Range
Dim cell As Variant

strPath = "U:\My Documents\Void_Detail_Template_TEST.xlsx"
strSavePath = "U:\My Documents\Void Detail Report.xlsx"

'_________Excel__________

Set xlApp = CreateObject("Excel.Application")
Set r01 = db.OpenRecordset("Invoice")
'_________Output Invoices__________
With xlApp
.Workbooks.Open strPath
.DisplayAlerts = False
.Visible = True
.Sheets("Invoice").Select
.Range("A2").CopyFromRecordset r01
.Cells.EntireColumn.AutoFit

End With

'_________LateFees_________
With xlApp
.Sheets("Late Fees").Select
.Range("A2").CopyFromRecordset r02
.Cells.EntireColumn.AutoFit
.Range("A1").Select
.Sheets("Invoice").Select

End With

'----------------------------------Here is where I filter and then take the data and copy to new sheet
Dim x As Range
Dim rng As Range
Dim last As Long
Dim wks As String
Dim wksName As String
Dim GetWorksheet As Worksheet
On Error Resume Next

Set GetWorksheet = Worksheets(wks)

'specify sheet name in which the data is stored*********************************
wks = "Invoice"


Dim iLast%
With xlApp
xlApp.Range("A1").Select

iLast = xlApp.Selection.End(xlDown).Row

Set xlApp.rng = xlApp.Range("A1:I" & iLast)


xlApp.Range("I1:I" & iLast).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=xlApp.Range("AA1"), Unique:=True

For Each x In Range([AA2], xlApp.Cells(.Rows.Count, "AA").End(xlUp))

If Not GetWorksheet(x.Text) Is Nothing Then
.Sheets(x.Text).Delete
End If


With xlApp.Sheets(wks).Range("A1:I" & iLast)

.AutoFilter
.AutoFilter Field:=9, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

xlApp.Sheets.Add(After:=xlApp.Sheets(xlApp.Sheets.Count)).Name = ("Invoice - ") & (x.Value - 1)
xlApp.ActiveSheet.Paste
End With
Next x

' Turn off filter
.Sheets(wks).AutoFilterMode = False


'******************************************************************************************************

'********************************************************************************

'Save the work book and advise user of location


'******************************************************************************************************

'Code will rename and hide Invoice table if duplicates exists
'and rename to Invoice Master

Dim m%

'Loop through all the worksheets after the spreadsheet has been broken out
'If there are any duplicates identified/starting with Invoice - 0, then rename the main
'Invoice tabe to Invoice Main and hide it. Then rename Invoice - 0 to Invoice

For m = 1 To ActiveWorkbook.Sheets.Count

If xlApp.Sheets(m).Name = "Invoice - 0" Then

xlApp.Sheets("Invoice").Name = "Invoice Main"
xlApp.Sheets("Invoice Main").Visible = False
xlApp.Sheets("Invoice - 0").Name = "Invoice"


End If


Next m
'********************************************************************************

'Save the work book and advise user of location
Continue:
With xlApp
xlApp.DisplayAlerts = False
.ActiveWorkbook.SaveAs strSavePath
xlApp.DisplayAlerts = True
.Quit
End With


Set xlApp = Nothing
MsgBox ("Report Has Been Saved to: " & vbCrLf & vbCrLf & strSavePath)

End With

End Function


Any help would be appreciated.

 

[bobsan42]

Sorrybto say so, but it's a messy code.
It needs a lot of fixing. And there are a lot of inconsistencies meaning you do same thing in different ways
A couple of examples (i just scrolled quickly through it on my mobile):
Range objects are members of the worksheet object, NOT of the Application one.
Use worksheets instead of sheets JIC, unless you really need it e.g. sheets.count
You do this Set GetWorksheet = Worksheets(wks), but you give a value to wks later in the code.

 

[bobsan42]

Do you run this code from Access ?
Although it is pretty obvious, you should mention things like that. And use code tags when inserting code in your posts.

 

[bobsan42]

a few tips:
only rely on Selected/activated objects as a last resort - rather refer to the objects as such
close your recordsets and set your variables to nothing or null, esp. the database objects (db, rs, ...)

Try the code like this (here is just the second part - editted):

...

'_________Paths_________
Dim strPath$, strSavePath$, strfilenm$
Dim source As Range
Dim cell As Variant
Dim wb As Workbook, sh As Worksheet

strPath = "U:\My Documents\Void_Detail_Template_TEST.xlsx"
strSavePath = "U:\My Documents\Void Detail Report.xlsx"

'_________Excel__________

Set xlApp = CreateObject("Excel.Application")
'Set r01 = db.OpenRecordset("Invoice") '## I think you already did this above, so maybe it is not needed
'_________Output Invoices__________
With xlApp
    Set wb = .Workbooks.Open(strPath)
    .DisplayAlerts = False
    .Visible = True
End With

'specify sheet name in which the data is stored*********************************
Dim wks As String
wks = "Invoice"

Set sh = wb.Worksheets(wks)
With sh
    .Range("A2").CopyFromRecordset r01
    .Cells.EntireColumn.AutoFit
End With

'_________LateFees_________
With wb.Worksheets("Late Fees")
    .Range("A2").CopyFromRecordset r02
    .Cells.EntireColumn.AutoFit
End With

'----------------------------------Here is where I filter and then take the data and copy to new sheet
Dim x As Range
Dim rng As Range
Dim last As Long
Dim GetWorksheet As Worksheet
On Error Resume Next

Set GetWorksheet = Worksheets(wks)
Dim iLast%
With sh
    iLast = .Range("A1").End(xlDown).Row
    Set rng = .Range("A1:I" & iLast)
    .Range("I1:I" & iLast).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
    For Each x In .Range([AA2], .Cells(.Rows.Count, "AA").End(xlUp))
    
        If Not GetWorksheet(x.Text) Is Nothing Then wb.Worksheets(x.Text).Delete '# I am utterly confused by the condition at the beginning of this line, _
        What are you looking for here - Worksheets ??? This probably does not work in that way and is wrong, but you can't see it because of Resuming on error
        'Maybe the condition should be: _
        If Not wb.Worksheets(x.Text) Is Nothing Then wb.Worksheets(x.Text).Delete _
        Although, because you resume on error you can try to delete directly, without checking: _
        wb.Worksheets(x.Text).Delete
        
    
        With .Range("A1:I" & iLast)
            
            .AutoFilter
            .AutoFilter Field:=9, Criteria1:=x.Value
            .SpecialCells(xlCellTypeVisible).Copy
            
            Set GetWorksheet = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            GetWorksheet.Name = ("Invoice - ") & (x.Value - 1)
            GetWorksheet.Paste
        End With
    Next x

    ' Turn off filter
    .AutoFilterMode = False

End With
'******************************************************************************************************
'Save the work book and advise user of location
'******************************************************************************************************

'Code will rename and hide Invoice table if duplicates exists
'and rename to Invoice Master
Dim m%
'Loop through all the worksheets after the spreadsheet has been broken out
'If there are any duplicates identified/starting with Invoice - 0, then rename the main
'Invoice tabe to Invoice Main and hide it. Then rename Invoice - 0 to Invoice

With wb
    For m = 1 To .Sheets.Count
        If .Worksheets(m).Name = "Invoice - 0" Then
            .Worksheets("Invoice").Name = "Invoice Main"
            .Worksheets("Invoice Main").Visible = False
            .Worksheets("Invoice - 0").Name = "Invoice"
        End If
    Next m
    '********************************************************************************
    'Save the work book and advise user of location
Continue:
    xlApp.DisplayAlerts = False
    wb.SaveAs strSavePath
    xlApp.DisplayAlerts = True
    xlApp.Quit
End With

Set xlApp = Nothing
Set wb = Nothing
Set sh = Nothing
MsgBox ("Report Has Been Saved to: " & vbCrLf & vbCrLf & strSavePath)

 

[mwalsh]

Thank you very much bobans42. And yes the code is really messy. I used what you gave me and it ran perfect the first time but again when I run the database (run button that calls the module) it loses the x value. When I hover over it, it tells me the variable is not set and the value is nothing. If I reset the module it runs fine again.

For Each x In .Range([AA2], .Cells(.Rows.Count, "AA").End(xlUp))

With .Range("A1:I" & iLast)

.AutoFilter
.AutoFilter Field:=9, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

 

[mwalsh]

I was able to use the code above to get what I need thanks so much.

 

[bobsan42]

I was able to use the code above to get what I need thanks so much.

What was the problem? Did you manage to make it work?