Copying cells from multiple files in 1 folder based on partial file name

user_19181168 0
Viewed 46

I made a post Copying cells from multiple files in one folder.

This answer was correct however I need to change it.

The code from this:

Sub Macro()

 Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
 Const strPath As String = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" 'take care of the ending backslash

 Set TargetWb = Workbooks("X.xlsm")
 Set ws = TargetWb.Sheets("Macro")
 i = 3

 StrFile = Dir(strPath & "*.xls*") 'it returns all files having extensions as xls, xlsx, xlsm, xlsa, xlsb
 Dim sheetName As String: sheetName = "S"
 Do While Len(StrFile) > 0
     StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
     ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
     ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
    
    i = i + 1
    StrFile = Dir() 'needed to continue the iteration up to the last file
 Loop
 
End Sub

In the folder where I pull the two data points from there are over 1000 workbooks. I only need the data from around 20/30 of these.
I was planning on getting all the data from this folder and then doing a quick play around to get to the stuff I need. The macro to pull from these 1000 docs is causing Excel to crash.

Is it possible to only pull the data from these files if part of the file name matches with a list of codes in the master sheet?

For example, in column B there are 20 codes listed "3333", "44444" , "562872" etc. and the only files I want are "ABCD 3333 BDBD", "AJKP 4444" and "hhhhh 562872 ha".

vba excel
1 Answers

Using the function InStr() and an array could do the trick:

Sub Macro()

    Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
    Const strPath As String = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" 'take care of the ending backslash
    'this is the range where the filename codes are. Change as needed
    Dim arr_files As Variant: arr_files = ThisWorkbook.Sheets("Master").Range("B2:B20")
    Set TargetWb = Workbooks("X.xlsm")
    Set ws = TargetWb.Sheets("Macro")
    i = 3
    
    StrFile = Dir(strPath & "*.xls*") 'it returns all files having extensions as xls, xlsx, xlsm, xlsa, xlsb
    Dim sheetName As String: sheetName = "S"
    Do While Len(StrFile) > 0
        If Not file_to_process(StrFile, arr_files) Then GoTo skip_file
        StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
        ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
        ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
        i = i + 1
skip_file:
        StrFile = Dir() 'needed to continue the iteration up to the last file
    Loop
 
End Sub
Private Function file_to_process(file_name As String, arr_files As Variant) As Boolean
    
    Dim Key As Variant
    For Each Key In arr_files
        If InStr(1, file_name, Key, vbTextCompare) > 0 Then
            file_to_process = True
            Exit For
        End If
    Next Key

End Function

I've created a little function to check every filename for every code in the arr_files so if one filename has a code in the string, will check as true and get the data.

user_75586820
Related