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!

 

[pbornemeier]

Step through and see if it does what you need.
You may want to consider only using the first cell of the paste range so there is no possibility of duplicating rows if the source cell count is less than the destination cell count.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Put this code in the code page of the worksheet that holds your data
    'Double click on a row to open the associated file & copy data
    
    Dim sPath As String
    Dim sFileNameExt As String
    Dim lRow As Long
    Dim sDestinationRange As String
    Dim wb As Workbook
    Dim sActiveSheet As String
    Dim sBasePath As String
    
    sBasePath = "https://sharepoint.com/sites/Group/Shared%20Documents/My%20Team/Data/"
    
    sActiveSheet = ActiveSheet.Name
    
    lRow = Target.Row                               'Determine the row that was clicked
    'If lRow < 1 Or lRow > 999999 Then GoTo End_Sub  'Uncomment and edit numbers if you want to limit the rows
                                                    '     that this code will respond to
    'Extract Data from row
    sPath = sBasePath
    sPath = sPath & Format(Cells(lRow, 3).Value, "mmmm")    'This adds the month name 'January'
    sPath = sPath & " Data"                         'This adds ' Data' to the end of the month name 'January Data'
    
    sFileNameExt = Cells(lRow, 5).Value             'FileName.Ext  not sure if column E contains filename and extension
    
    sDestinationRange = Cells(lRow, 8).Value        'Destination Cells
    
    'Check if Folder/File Exists
    If FolderExists(sPath) Then                    'Verify folder exists
        sPath = FixPath(sPath)                     'Ensure it ends with \
        Cancel = True                              'Cancel double-click
    Else
        CreateObject("WScript.Shell").Popup sPath, 10, "Path does not exist"
        GoTo End_Sub
    End If
    
    If FileExists(sPath & sFileNameExt) Then       'Verify file exists
        Cancel = True                              'Cancel double-click
    Else
        CreateObject("WScript.Shell").Popup sPath & sFileNameExt, 10, "File does not exist"
        GoTo End_Sub
    End If
    
    'Open file
    Set wb = Workbooks.Open(sPath & sFileNameExt)
    If wb Is Nothing Then GoTo End_Sub
     
    'Copy ranges from selected item into current worksheet
    wb.Sheets(1).Range("F21:F116").Copy
    ThisWorkbook.Worksheets(sActiveSheet).Range(sDestinationRange).PasteSpecial (xlPasteValues)
    wb.Close False
    
End_Sub:
   
End Sub
 
Function FolderExists(ByVal FileSpec As String) As Boolean
    'Returns True if Folder path exists whether ending in \ or not
    ' Karl Peterson MS VB MVP
    Dim Attr As Long
    ' Guard against bad FileSpec by ignoring errors
    ' retrieving its attributes.
    On Error Resume Next
    Attr = GetAttr(FileSpec)
    If Err.Number = 0 Then
    ' No error, so something was found.
    ' If Directory attribute set, then not a file.
        FolderExists = ((Attr And vbDirectory) = vbDirectory)
    End If
End Function
 
Function FileExists(ByVal FileSpec As String) As Boolean
    'Returns True if Folder path exists whether ending in \ or not
    ' Karl Peterson MS VB MVP
    Dim Attr As Long
    ' Guard against bad FileSpec by ignoring errors
    ' retrieving its attributes.
    On Error Resume Next
    Attr = GetAttr(FileSpec)
    If Err.Number = 0 Then
    ' No error, so something was found.
    ' If Directory not attribute set, then is a file.
        FileExists = Not ((Attr And vbDirectory) = vbDirectory)
    End If
End Function
 
Function FixPath(sPath) As String
    'Ensure that the sPath path ends in a single path separator
    '  and does not contain multiple sequential path separators
 
    Dim sPathSep As String
    Dim lX As Long
    
    sPathSep = Application.PathSeparator
    
    sPath = Trim(sPath)
    Do While Right(sPath, 1) = sPathSep
        sPath = Left(sPath, Len(sPath) - 1)
    Loop
    For lX = Len(sPath) - 1 To 2 Step -1
        If Mid(sPath, lX, 1) = sPathSep And Mid(sPath, lX + 1, 1) = sPathSep Then
            sPath = Left(sPath, lX - 1) & Mid(sPath, lX + 1)
        End If
    Next
    sPath = sPath & sPathSep
    FixPath = sPath
    
End Function

 

[Fraxav]

Hi Phil,

Thank you very much for this! I have pasted the code into the code page of Sheet2 of my workbook and made some tweaks to reflect the new naming system:

'Extract Data from row
    sPath = sBasePath
    sPath = sPath & Format(Cells(lRow, 3).Value, "yyyy")    'This adds the year
    sPath = sPath & "-"                                     'This adds an hyphen
    sPath = sPath & Format(Cells(lRow, 3).Value, "mm")      'This adds the month number
    sPath = sPath & "%20Raw%20Data/"                         'This adds ' Raw Data/' to the end of the folder name
  
    sFileNameExt = "20210104_124317_CT048068_EXT" & "_" & Cells(lRow, 5).Value & ".csv"             'FileName.Ext

N.B. I will need to replace "20210104_124317_CT048068_EXT" with a wildcard ("*") as the first part of each filename is unpredictable and I would like the macro to ignore it, but a simple "*" did not do it and that's where my knowledge stops...

Anyway, that seems to work fine, but trouble begins with the path/file checking code:

    'Check if Folder/File Exists
    If FolderExists(sPath) Then                    'Verify folder exists
        sPath = FixPath(sPath)                     'Ensure it ends with \
        Cancel = True                              'Cancel double-click
    Else
        CreateObject("WScript.Shell").Popup sPath, 10, "Path does not exist"
        GoTo End_Sub
    End If
  
    If FileExists(sPath & sFileNameExt) Then       'Verify file exists
        Cancel = True                              'Cancel double-click
    Else
        CreateObject("WScript.Shell").Popup sPath & sFileNameExt, 10, "File does not exist"
        GoTo End_Sub
    End If

The macro seems to believe that the path and folder do not exist and return the error messages. However, the path and filename are correct and existing (see below).

After commenting the Else statements for both FolderExists and FileExists, the macro successfully finds the right file, opens it and copies the appropriate cells. However, it returns a runtime 1004 application-defined or object-defined error at the pasting step:

ThisWorkbook.Worksheets(sActiveSheet).Range(sDestinationRange).PasteSpecial (xlPasteValues)

I was able to solve this by replacing sDestinationRange with the cell address that I was aiming for ("H892"in the example above). After that, the macro completed successfully!

So, my questions are:
- how can I make the macro ignore the first part of the target filename (e.g. with a wildcard or simply looking for the last part of the filename)?
- why is the macro not finding the path/file when it checks if they exist (and they do)?
- how can I correctly point to my destination range, keeping in mind that it should vary depending on the position of the double-click (i.e. on the same row).

Thank you so much!

 

[pbornemeier]

Some answers

I am assuming that the %20 is not actually part of the actual filename (as shown in windows explorer or with a Dir command) although it could be if your files are being generated from another system. I have not done much with sharepoint, but that could be the case.

- how can I make the macro ignore the first part of the target filename (e.g. with a wildcard or simply looking for the last part of the filename)?
The * will work when using the Dir command, but the GetAttr command (used in the FileExists and Folder Exists functions) does not like it.
I rewrote that portion of code to use Dir to check if the entire FilePathNameExt exists. This could cause problems if there was more than one filename that ends with the filename value in column 5 of the clicked row.

- why is the macro not finding the path/file when it checks if they exist (and they do)?
I believe that using the %20%20 as part of the path literal string caused this

- how can I correctly point to my destination range, keeping in mind that it should vary depending on the position of the double-click (i.e. on the same row).
Using Target.Address will return the address of the cell you clicked on

I rewrote the code to take care of the above. The other functions are not needed. Step through and see if it does what you want.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Put this code in the code page of the worksheet that holds your data
    'Double click on a row to open the associated file & copy data
    
    Dim sPath As String
    Dim sFileNameExt As String
    Dim lRow As Long
    Dim wb As Workbook
    Dim sActiveSheet As String
    Dim sBasePath As String
    
    sBasePath = "https://sharepoint.com/sites/Group/Shared%20Documents/My%20Team/Data/"
    
    sActiveSheet = ActiveSheet.Name
    
    lRow = Target.Row                               'Determine the row that was clicked
    'If lRow < 1 Or lRow > 999999 Then GoTo End_Sub  'Uncomment and edit numbers if you want to limit the rows
                                                    '     that this code will respond to
    'Extract Data from row
    sPath = sBasePath
    sPath = sPath & Format(Cells(lRow, 3).Value, "yyyy-mm")    'This adds the year-month (2001-01)
    sPath = sPath & " Raw Data/"                         'This adds ' Raw Data/' to the end of the folder name
                                    'I changed %20 to a space.  The %20 would be put in as literal
    
    sFileNameExt = "*_" & Cells(lRow, 5).Value          'will find any filename ending in: _FileName.Ext
    
    sDestinationRange = Cells(lRow, 8).Value        'Destination Cells
    
    'Temporary -------------------------
    Debug.Print sPath
    Debug.Print sFileNameExt
    Stop                                            'Is Path & FileNameExt what you expect?
    'End Temporary -------------------------
    
    'Check if Folder/File Exists
    If Len(Dir(sPath & sFileNameExt)) > 2 Then
        'Open file
        Set wb = Workbooks.Open(sPath & sFileNameExt)
        If wb Is Nothing Then GoTo End_Sub
         
        'Copy ranges from selected item into current worksheet
        wb.Sheets(1).Range("F21:F116").Copy
        ThisWorkbook.Worksheets(sActiveSheet).Range(Target.Address).PasteSpecial (xlPasteValues)
        wb.Close False
    End If
    
End_Sub:
   
End Sub

 

[Fraxav]

Hi Phil,

Thanks a lot for the extra work and for your quick reply! Unfortunately, I had more hiccups with the new code and I had to comment out the following to make it work:

sDestinationRange = Cells(lRow, 8).Value          'Not declared and apparently not needed anymore?

'Temporary ------------------------------          'Did not seem to work (macro stops and debugger highlights Stop)
Debug.Print sPath
Debug.Print sFileNameExt
Stop                                       
'End Temporary -------------------------

If Len(Dir(sPath & sFileNameExt)) > 2 Then          'This gave me a "bad file name or number" error, even when I provided the entire filename insted of using * (see below)

[SIZE=1].[/SIZE]

Without those lines, the macro did the job but I still had to specify the initial part of my filename as the "*_" bit did not work (I tried with and without %20 and with and without & ".csv" at the end of the file name):

I do not want to take too much of your time, so maybe we could restrict the troubleshooting to the wildcard? Also, I have been trying to move this macro to a button (with some success), but anything that I use to define ThisWorkbook.Worksheets(sActiveSheet).Range() to paste in a position relative to the button (e.g. Cells(TargetRow, 8).Value) gives me an application-defined or object-defined error for that expression.

Any further help would be IMMENSELY appreciated!

P.S. I do not seem able to step through this particular macro. Debug>Step in or F8 do not work. Could it be because of the type of Sub?

 

[Fraxav]

I should have specified that this is what I use to paste relative to the button location:

...
TargetRow = ActiveSheet.Buttons(Application.Caller).TopLeftCell.Row
...
PasteHere = Cells(TargetRow, 8).Value
...
ThisWorkbook.Worksheets(DestinationSheet).Range(PasteHere).PasteSpecial (xlPasteValues)
...

 

[Fraxav]

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:

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:

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!

 

[pbornemeier]

This part was in there so we could see the values of sPath and sFileNameExt which would be printed in the debug window and visible when the code stopped at the Stop command. F5 would be used to continue

'Temporary ------------------------------          'Did not seem to work (macro stops and debugger highlights Stop)
Debug.Print sPath
Debug.Print sFileNameExt
Stop                                      
'End Temporary -------------------------

Does the filename that ends in _PCR99832 have an extension? If so it needs to be added to the variable if it is some type of Excel workbook then use:

     sFileNameExt = "*_" & Cells(lRow, 5).Value & ".xls*"     'will find any filename ending in: _FileName.Ext

Yes this can go away:

sDestinationRange = Cells(lRow, 8).Value          'Not declared and apparently not needed anymore?

Do you really want to add a button to each row? That is why I chose to use the double-click method, much less work. I will think about how to do that.

Revised code:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'Put this code in the code page of the worksheet that holds your data
    'Double click on a row to open the associated file & copy data
   
    Dim sPath As String
    Dim sFileNameExt As String
    Dim lRow As Long
    Dim wb As Workbook
    Dim sActiveSheet As String
    Dim sBasePath As String
   
    sBasePath = "https://sharepoint.com/sites/Group/Shared%20Documents/My%20Team/Data/"
    sActiveSheet = ActiveSheet.Name
   
    lRow = Target.Row                                   'Determine the row that was clicked
    'If lRow < 1 Or lRow > 999999 Then GoTo End_Sub     'Uncomment and edit numbers if you want to limit the rows
                                                        '    that this code will respond to
    'Extract Data from row
    sPath = sBasePath
    sPath = sPath & Format(Cells(lRow, 3).Value, "yyyy-mm")    'This adds the year-month (2001-01)
    sPath = sPath & " Raw Data/"                         'This adds ' Raw Data/' to the end of the folder name
   
    sFileNameExt = "*_" & Cells(lRow, 5).Value & ".xls*"         'will find any filename ending in: _FileName.xls*
   
    On Error Resume Next
    sFileNameExt = Dir(sPath & sFileNameExt)    'This returns the full filename for the first file that matches the pattern defined above
    If Err.Number <> 0 Then
        MsgBox "The FilePath & FileNameExt combination was not valid" & vbLf & vbLf & _
            "    Path: " & vbTab & sPath & vbLf & _
            "    Name.Ext: " & vbTab & sFileNameExt & vbLf & vbLf & _
            ""
        Debug.Print Now() & "--------------------------------------- Not Found"
        Debug.Print sPath           'Print value in Immediate window as a troubleshooting reference
        Debug.Print sFileNameExt    'Print value in Immediate window as a troubleshooting reference
        Debug.Print
        GoTo End_Sub
    End If
    On Error GoTo 0
   
    'Since the command Dir(sPath & sFileNameExt) will return a file from the parent folder if sFileNameExt = ".."
    If Len(sFileNameExt) < 3 Then
        MsgBox "The FileNameExt is too short" & vbLf & vbLf & _
            "    Path: " & vbTab & sPath & vbLf & _
            "    Name.Ext: " & vbTab & sFileNameExt & vbLf & vbLf & _
            ""
        Debug.Print Now() & "--------------------------------------- Too Short"
        Debug.Print sPath           'Print value in Immediate window as a troubleshooting reference
        Debug.Print sFileNameExt    'Print value in Immediate window as a troubleshooting reference
        Debug.Print
        GoTo End_Sub
    End If

'    Dir results
'    dir("C:\temp\..")   Returns a file in the parent folder
'    dir("C:\temp\.")    Returns a file in the temp folder
'    dir("C:\temp\*")    Returns a file in the temp folder
'    dir("C:\temp")      returns nothing because there is not file named "temp" in the C:\ folder
'    dir("C:\temp\")     Returns a file in the temp folder
   
    'Open file
    Set wb = Workbooks.Open(sPath & sFileNameExt)
    If wb Is Nothing Then GoTo End_Sub
    
    'Copy ranges from selected item into current worksheet
    wb.Sheets(1).Range("F21:F116").Copy
    ThisWorkbook.Worksheets(sActiveSheet).Range(Target.Address).PasteSpecial (xlPasteValues)
    wb.Close False
   
End_Sub:
  
End Sub

 

[Fraxav]

Dear Phil,

The updated macro has the same problem with the wildcard:

As I mentioned in my last update (below) I eventually managed to add the macro to a button, which is a preferable approach for my purpose and will only involve creating a few buttons (i.e. not one per row):

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!

So the wildcard problem is the only thing keeping me from using the macro. If you could assist me in making it work that would be great help, as I am officially out of ideas!

 

[pbornemeier]

I thought I has responded a few days ago. But I guess not.

change

sFileNameExt = "*_" & Cells(lRow, 5).Value & ".xls*"

to

sFileNameExt = "*_" & Cells(lRow, 5).Value & ".csv"