VBA code to automatically find a file based on the content of multiple cells

[Fraxav]

Hi all,

I hope some of you experts can help me with this. I am trying to put together some VBA code to automatically select a source workbook from a Teams (Sharepoint) folder based on a couple of variables (folder name and filename suffix) that are provided within the cells of my destination worksheet. I would then like to use that source workbook to copy some of its cells into my destination worksheet.

In the example below, I would like to automatically find and activate the workbook named "Randomname_dp1"(based on cell E892) in the folder "January Data" (based on cell C892). Column H would be the destination range.

I am very new to VBA so with a bit of tweaking of other people's code I have just managed to open a dialog box at a specific Sharepoint location from where I can navigate to the desired workbook and copy its data:

Sub ImportResults()
Application.ScreenUpdating = False
Dim strFile As String, wb As Workbook

    'Open the File Dialog
    With Application.FileDialog(3)
         .AllowMultiSelect = False
         .InitialFileName = "https://sharepoint.com/sites/Group/Shared%20Documents/My%20Team/Data/"
         
         'Show the dialog box
         If .Show Then
         
            'Store in fullpath variable
            fullpath = .SelectedItems.Item(1)
            
            'open the file
            Set wb = Workbooks.Open(fullpath)
         End If
         If wb Is Nothing Then Exit Sub
         
        'Copy ranges from selected item into current worksheet
        wb.Sheets(1).Range("F21:F116").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range("A1:A96").PasteSpecial (xlPasteValues)
        wb.Close False
    End With
Application.ScreenUpdating = True
End Sub

Is there any way to have the macro automatically "navigate" the Data folder for me and find the correct workbook? And would it be possible to make the macro references relative, so that it can find different folders/files based on the cell from which it is run (e.g. via a button placed in cell B892 above)? A big bonus would be if the source workbook did not need to be opened to copy its data (so I don't have to suppress screen updating).

Thank you so much for your input!

 

[Fraxav]

Dear Phil,

I already modified the extension but that does not seem to be the problem. The trouble comes from the wildcard "*" being used as an asterisk character. Please see post below:

Dear Phil,

After a little trial and error, I have managed to adapt the macro to run when a button(form control) is clicked. It seems to work fine, except for the wildcard still not being recognised.

This is what I my destination table currently looks like, with the following macro existing in a module of the same workbook:

View attachment 29673

Option Explicit

Sub ImportSingleResults()
   
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
   
    Dim FilePath As String
    Dim FileDir As String
    Dim FileName As String
    Dim TargetRow As Long
    Dim wb As Workbook
   
    'SharePoint path to the data folder
    FilePath = "https://xxx.sharepoint.com/sites/yyy-zzz/Shared Documents/BDI Lab Team/Data/"
   
    'Determine row number based on position of macro button
    TargetRow = ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row
   
    'Determine the name of the target data folder from row
    FileDir = FilePath
    FileDir = FileDir & Format(Cells(TargetRow, 3).Value, "yyyy-mm")   'Adds the year-month
    FileDir = FileDir & " Raw Data/"                            'Adds ' Raw Data/' to the end of the month name 'January Data'
   
    'Determine the name of the target file
    FileName = "20210104_124317_CT048068_EXT_" & Cells(TargetRow, 5).Value & ".csv"
   
    'Open file
    Set wb = Workbooks.Open(FileDir & FileName)
    If wb Is Nothing Then Exit Sub

    'Copy and paste Cy5 or HEX
    If Application.WorksheetFunction.Count(wb.Sheets(1).Range("C2:C97")) > 0 Then
        wb.Sheets(1).Range("C2:C97").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    Else
        wb.Sheets(1).Range("C194:C289").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    End If
   
    'Copy and paste FAM
    wb.Sheets(1).Range("C98:C193").Copy
    ThisWorkbook.ActiveSheet.Activate
    ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -10).PasteSpecial (xlPasteValues)
   
    wb.Close False
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
  
End Sub

As before, I would like to not have to specify the initial part of the filename ("20210104_124317_CT048068_EXT_") and use "*" or "*_" instead, so that I can make the same button work with any table of the worksheet just by copying/pasting it in a different position. However, as I mentioned earlier, the wildcard seems to be interpreted as a character:

View attachment 29675

To my untrained eye, most people on the web seem to be able to use wildcards with Dir(), but I have encountered errors with that too. I assume it has something to do with my file being on a network drive rather than a local one?

Any insights on this would be extremely useful!

Could this have anything to do with creating paths to closed files? I have encoutered the same problem when trying to setup dynamic formula references to cells in closed workbooks.

 

[pbornemeier]

I have not had problems with * in a similar situation. Please post the code you are currently using.

How long is the entire expanded FilePathNameExt ?

 

[Fraxav]

The code (now triggered by a button rather than double click) is as below:

Option Explicit

Sub ImportSingleResults()
  
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
  
    Dim FilePath As String
    Dim FileDir As String
    Dim FileName As String
    Dim TargetRow As Long
    Dim wb As Workbook
  
    'SharePoint path to the data folder
    FilePath = "https://xxx.sharepoint.com/sites/yyy-zzz/Shared Documents/BDI Lab Team/Data/"                   'X, y and z represent sensitive parts of the path
  
    'Determine row number based on position of macro button
    TargetRow = ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row
  
    'Determine the name of the target data folder from row
    FileDir = FilePath
    FileDir = FileDir & Format(Cells(TargetRow, 3).Value, "yyyy-mm")   'Adds the year-month
    FileDir = FileDir & " Raw Data/"                            'Adds ' Raw Data/' to the end of the month name 'January Data'
  
    'Determine the name of the target file
    FileName = "*_" & Cells(TargetRow, 5).Value & ".csv"
  
    'Open file
    Set wb = Workbooks.Open(FileDir & FileName)
    If wb Is Nothing Then Exit Sub

    'Copy and paste Cy5 or HEX
    If Application.WorksheetFunction.Count(wb.Sheets(1).Range("C2:C97")) > 0 Then
        wb.Sheets(1).Range("C2:C97").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    Else
        wb.Sheets(1).Range("C194:C289").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    End If
  
    'Copy and paste FAM
    wb.Sheets(1).Range("C98:C193").Copy
    ThisWorkbook.ActiveSheet.Activate
    ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -10).PasteSpecial (xlPasteValues)
  
    wb.Close False
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
 
End Sub

Lenght-wise, the entire file path looks like:

https://xxxxxxxxxx.sharepoint.com/sites/yyyyyyyyyyyyyyy-zzzzzzzzzz/Shared Documents/BDI Lab Team/Data/2021-01 Raw Data/20210104_090712_CT048068_USER1_EXT_PCR99833.csv

The error message looks like this (at thhat time I might not have included the extension suffix but the result is the same):

 

[pbornemeier]

Added one line that should take care of it:
FileName = Dir(FileDir & FileName)

Option Explicit

Sub ImportSingleResults()
  
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
  
    Dim FilePath As String
    Dim FileDir As String
    Dim FileName As String
    Dim TargetRow As Long
    Dim wb As Workbook
  
    'SharePoint path to the data folder
    FilePath = "https://xxx.sharepoint.com/sites/yyy-zzz/Shared Documents/BDI Lab Team/Data/"                   'X, y and z represent sensitive parts of the path
  
    'Determine row number based on position of macro button
    TargetRow = ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row
  
    'Determine the name of the target data folder from row
    FileDir = FilePath
    FileDir = FileDir & Format(Cells(TargetRow, 3).Value, "yyyy-mm")   'Adds the year-month
    FileDir = FileDir & " Raw Data/"                            'Adds ' Raw Data/' to the end of the month name 'January Data'
  
    'Determine the name of the target file
    FileName = "*_" & Cells(TargetRow, 5).Value & ".csv"
    
    'This line returns the first filename that matches the pattern originally in Filename
    FileName = Dir(FileDir & FileName)
  
    'Open file
    Set wb = Workbooks.Open(FileDir & FileName)
    If wb Is Nothing Then Exit Sub

    'Copy and paste Cy5 or HEX
    If Application.WorksheetFunction.Count(wb.Sheets(1).Range("C2:C97")) > 0 Then
        wb.Sheets(1).Range("C2:C97").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    Else
        wb.Sheets(1).Range("C194:C289").Copy
        ThisWorkbook.ActiveSheet.Activate
        ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -9).PasteSpecial (xlPasteValues)
    End If
  
    'Copy and paste FAM
    wb.Sheets(1).Range("C98:C193").Copy
    ThisWorkbook.ActiveSheet.Activate
    ActiveSheet.Range(ActiveSheet.Buttons(Application.Caller).TopLeftCell.Address).Offset(0, -10).PasteSpecial (xlPasteValues)
  
    wb.Close False
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
 
End Sub

 

[Fraxav]

Hi Phil,

That line makes the macro crash with the following error:

 

[pbornemeier]

Fraxav,

Dir (which can use wildcards to find a matching file in a folder) will not work with a web address. I regret it took so long for met to see that problem.

As a fix, use the info/code here:

How to save the password for a mapped network drive?

I have a map drive created from Tools > Map network drive. The drive is mapped to a different machine's shared folder. So each time I switch off the machine, it asks for the password when I open the

superuser.com

How can I Map a Network Drive with Password so it stays mapped after a reboot?

I mapped a network drive to a location that needs a password. Now whenever my computer starts up, it tells me that it could not connect to that network drive because a password is needed. How do ...

superuser.com

to map the sharepoint folder to a network drive on your machine then reference that folder in the

FilePath =

statement your code.

Let me know ho that goes.

Phil