Copying cells from multiple files in 1 folder: Part 2-CodePudding

I recently made a post about copying cells from multiple files in 1 folder and got some great help.

Copying cells from multiple files in 1 folder

This answer was completely correct however I need to change it a little bit. I made a new post due to the fact that the answer on there does work, not sure if this is the right process.

The code I have got from this is shown below:


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 am pulling the two data points from there are actually over 1000 different workbooks. I only need the data from around 20/30 of these. Originally 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 as I thought this would be easier. Annoyingly, using the macro to pull from these 1000 docs is causing excel to crash so I need to play this slightly differently.

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 to pull data from are "ABCD 3333 BDBD", "AJKP 4444" and "hhhhh 562872 ha".

Please let me know if this is clear and if you think its possible to do very easily.

Thanks in advance!

CodePudding user response：

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.