Copy data from closed Workbook with advanced filter using VBA

[NDMDRB]

Hi,

I have the attached files, and I would like to extract data from one to another using advanced filter

Both Files

"Database" file is the closed one
"Report" file is the file that I would like to run the "UpdateDatabase" macro from

When I run the macro, it will get an error
Run-time error '1004':
Application-defined or object-defined error

When debug the error, the filter lines will be highlighted


What I need from this code is:

• Check if "Database" file is currently open or not
• If not, get the required data and then close it
• If yes, get the required data only

Any help will be highly appreciated

 

[dmt32]

Hi,
There were a few errors in your code - see if this update helps you

Option Explicit

Sub UpdateDatabase()
    Dim FileName    As String, FilterCriteria As String
    Dim nwb         As Workbook     'The database file
    Dim ndb         As Range        'Filter range from the external file
    Dim wse         As Worksheet
    Dim WholeOrPart As XlLookAt
  
   On Error GoTo myerror
 
   Set wse = Sheet1
 
   '**********************************************************************************************************
   '*********************************************SETTINGS*****************************************************
 
   WholeOrPart = xlWhole
 
   FilterCriteria = "Tool Carrier"
 
   '*********************************************************************************************************
  
    FileName = wse.Range("Equip_BrowseFile")
  
    If Not Dir(FileName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        'open database read only
        Set nwb = Workbooks.Open(FileName, False, True)        'Sheet1.Range("I2")
      
        With nwb.Sheets(1)
            Set ndb = .Range("A2:G2").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row)
          
            'clear filter criteria
            .Range("K3:Q3").ClearContents
          
          
            If WholeOrPart = xlWhole Then
                'exact match
                .Range("N3").Formula = "=" & """=" & FilterCriteria & """"
            Else
                'part match
                .Range("N3").Value = FilterCriteria
            End If
            'apply filter
            ndb.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("K2:Q3"), _
                               CopyToRange:=wse.Range("Equip_ExtractData"), Unique:=False
          
        End With
      
    Else
        'file not found
        Err.Raise 53
    End If
  
myerror:
    If Not nwb Is Nothing Then nwb.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

I have set the Open method to Read Only as this should hopefully, allow code to run whether the workbook is open or not.
If you have made changes to the open workbook, Save before running code.

Also, I have included filter match choice in the Filter Criteria -
your code was only applying a part match - update allows you set xlWhole or xlPart as required.

Note also, I have hard coded the filter criteria range - your named range excluded the field headers

Hope Helpful

Dave

 

[NDMDRB]

Hi,
There were a few errors in your code - see if this update helps you

Option Explicit

Sub UpdateDatabase()
    Dim FileName    As String, FilterCriteria As String
    Dim nwb         As Workbook     'The database file
    Dim ndb         As Range        'Filter range from the external file
    Dim wse         As Worksheet
    Dim WholeOrPart As XlLookAt
 
   On Error GoTo myerror

   Set wse = Sheet1

   '**********************************************************************************************************
   '*********************************************SETTINGS*****************************************************

   WholeOrPart = xlWhole

   FilterCriteria = "Tool Carrier"

   '*********************************************************************************************************
 
    FileName = wse.Range("Equip_BrowseFile")
 
    If Not Dir(FileName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        'open database read only
        Set nwb = Workbooks.Open(FileName, False, True)        'Sheet1.Range("I2")
     
        With nwb.Sheets(1)
            Set ndb = .Range("A2:G2").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row)
         
            'clear filter criteria
            .Range("K3:Q3").ClearContents
         
         
            If WholeOrPart = xlWhole Then
                'exact match
                .Range("N3").Formula = "=" & """=" & FilterCriteria & """"
            Else
                'part match
                .Range("N3").Value = FilterCriteria
            End If
            'apply filter
            ndb.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("K2:Q3"), _
                               CopyToRange:=wse.Range("Equip_ExtractData"), Unique:=False
         
        End With
     
    Else
        'file not found
        Err.Raise 53
    End If
 
myerror:
    If Not nwb Is Nothing Then nwb.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

I have set the Open method to Read Only as this should hopefully, allow code to run whether the workbook is open or not.
If you have made changes to the open workbook, Save before running code.

Also, I have included filter match choice in the Filter Criteria -
your code was only applying a part match - update allows you set xlWhole or xlPart as required.

Note also, I have hard coded the filter criteria range - your named range excluded the field headers

Hope Helpful

Dave

Thank you so much dmt32, I really appreciate your support

There is one more thing if you please
With your code, after getting data, the database file will close even if it was opened previously
What I mean is, if I'm using the database file before I run this code, I need to extract the data and keep the database file open, otherwise, close it

Is it possible to do this?

 

[dmt32]

What I mean is, if I'm using the database file before I run this code, I need to extract the data and keep the database file open, otherwise, close it

Is it possible to do this?

change this line

If Not nwb Is Nothing Then nwb.Close False

to this

If Not nwb Is Nothing And nwb.ReadOnly Then nwb.Close False

sorry, overlooked that requirement but hopefully, this will resolve.

Dave

 

[NDMDRB]

change this line

If Not nwb Is Nothing Then nwb.Close False

to this

If Not nwb Is Nothing And nwb.ReadOnly Then nwb.Close False

sorry, overlooked that requirement but hopefully, this will resolve.

Dave

I'm so sorry for bothering you dear, this problem is fixed and thanks a lot

But if the database file is closed then I get an error msg ("Out of memory")

 

[dmt32]

try this update to the whole code.

Option Explicit

Sub UpdateDatabase()
    Dim FileName    As String, FilterCriteria As String
    Dim nwb         As Workbook     'The database file
    Dim ndb         As Range        'Filter range from the external file
    Dim wse         As Worksheet
    Dim WholeOrPart As XlLookAt
    Dim NotOpen     As Boolean
    
   
   Set wse = Sheet1
   
   '**********************************************************************************************************
   '*********************************************SETTINGS*****************************************************
   
   WholeOrPart = xlWhole
   
   FilterCriteria = "Tool Carrier"
   
   '*********************************************************************************************************
    
    FileName = wse.Range("Equip_BrowseFile")
    
    On Error Resume Next
     Set nwb = Workbooks(Mid$(FileName, InStrRev(FileName, "\") + 1))
     NotOpen = CBool(Err.Number = 9)
     
   On Error GoTo myerror
   
    If NotOpen Then
        If Not Dir(FileName, vbDirectory) = vbNullString Then
            Application.ScreenUpdating = False
            'open database read only
            Set nwb = Workbooks.Open(FileName, False, True)        'Sheet1.Range("I2")
        Else
            'file not found
            Err.Raise 53
        End If
    End If
        
        With nwb.Sheets(1)
            Set ndb = .Range("A2:G2").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row)
            
            'clear filter criteria
            .Range("K3:Q3").ClearContents
            
            
            If WholeOrPart = xlWhole Then
                'exact match
                .Range("N3").Formula = "=" & """=" & FilterCriteria & """"
            Else
                'part match
                .Range("N3").Value = FilterCriteria
            End If
            'apply filter
            ndb.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("K2:Q3"), _
                               CopyToRange:=wse.Range("Equip_ExtractData"), Unique:=False
            
        End With
            
myerror:
    If Not nwb Is Nothing And nwb.ReadOnly Then nwb.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave