keyword search numerous files in one folder

Good day everyone, I was hoping if someone can kindly come up with a VBA code to help ease my stress.
I have a specific folder in the directory "\\Fps1ids\hmkqc\Inspection_Test Sheet\QAF" and it contains countless number of excel spreadsheet files, where each of them have a unique identity code in its name. (6 digit number)

Now, I have a masterfile spreadsheet that contains all of these identity numbers and I want to search the file name by this number to return two specific fields in the selected file.

For example, the first file has all the codes to be used as keyword search prompt, and once the file with matching keyword has been found, return the cell value to column E and J.

The second attached is one of many similar looking files that will be searched through to find a match.

As you can see, the file name contains the 6 digit keyword code.
(i.e QAF 9584 801000-HK1574-84inch-0545 )

Basically, find the file with matching 6 digit number and return the cell value for DIE # and CURE TIME. (HK 1574 and 3.50 respectively and no unit measures) When performing this, you need to do this by string searching CURE TIME and DIE # and return the value by moving a few cells to the right.(This format will stay the same as well as the number of cells to the right you move). Also, every file contains 2 worksheets named TEMPLATE and REVISION LOG in a random order, you want the TEMPLATE worksheet.

One more thing, when returning the DIE # the entry can be in 2 formats( HK XXXX and HK xx/xx" ).
For the first scenario, return the full value( HK XXXX) for second, return (xx/xx) only.


Thank you very much and I'd really appreciate any help.

hk4kim,

Your masterfile does not contain any keyword codes to search for. Are they supposed to be in column A starting in row 2 and going down?

[EDIT]:
Nevermind, I found the keywords (product codes). I just wasn't scrolled all the way to the left ><. Working on a solution, shouldn't take very long.

hk4kim,

Give this a try:

Sub tgr()
    
    Const strFolderPath As String = "\\Fps1ids\hmkqc\Inspection_Test Sheet\QAF\"
    
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    Dim rngFound As Range
    Dim rngKeyWords As Range
    Dim KeyWordCell As Range
    Dim lCalc As XlCalculation
    Dim lMacroSec As MsoAutomationSecurity
    Dim arrFiles() As Variant
    Dim arrDieNo() As Variant
    Dim arrCures() As Variant
    Dim strFileName As String
    Dim arrIndex As Long
    Dim lMatch As Long
    
    Set wsDest = ActiveWorkbook.Sheets("Sheet1")
    Set rngKeyWords = wsDest.Range("A2", wsDest.Cells(Rows.Count, "A").End(xlUp))
    If rngKeyWords.Row < 2 Then GoTo CleanExit  'No data
    
    With Application
        lCalc = .Calculation
        lMacroSec = .AutomationSecurity
        .Calculation = xlCalculationManual
        .AutomationSecurity = msoAutomationSecurityForceDisable
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    On Error GoTo CleanExit
    
    arrIndex = 0
    ReDim arrFiles(1 To 65000)
    strFileName = Dir(strFolderPath & "*.xls*")
    
    Do While Len(strFileName) > 0
        arrIndex = arrIndex + 1
        arrFiles(arrIndex) = strFileName
        strFileName = Dir
    Loop
    
    If arrIndex > 0 Then ReDim Preserve arrFiles(1 To arrIndex) Else GoTo CleanExit
    arrIndex = 0
    
    ReDim arrDieNo(1 To rngKeyWords.Rows.Count)
    ReDim arrCures(1 To rngKeyWords.Rows.Count)
    
    On Error Resume Next
    For Each KeyWordCell In rngKeyWords.Cells
        arrIndex = arrIndex + 1
        lMatch = 0
        lMatch = WorksheetFunction.Match("*" & KeyWordCell.Text & "*", arrFiles, 0)
        If lMatch > 0 Then
            With Workbooks.Open(strFolderPath & arrFiles(lMatch))
                For Each ws In .Sheets
                    If InStr(1, ws.Name, "Template", vbTextCompare) > 0 Then
                        Set rngFound = ws.Cells.Find("DIE #", , xlValues, xlPart)
                        If Not rngFound Is Nothing Then
                            Select Case (InStr(1, rngFound.Offset(, 4).Text, "/", vbTextCompare) > 0)
                                Case True:  arrDieNo(arrIndex) = Trim(Replace(LCase(rngFound.Offset(, 4).Text), "hk", vbNullString))
                                Case Else:  arrDieNo(arrIndex) = Trim(rngFound.Offset(, 4).Text)
                            End Select
                        End If
                        Set rngFound = ws.Cells.Find("CURE TIME", , xlValues, xlPart)
                        If Not rngFound Is Nothing Then arrCures(arrIndex) = CDbl(Trim(Left(Replace(WorksheetFunction.Trim(rngFound.End(xlToRight).Text), " ", String(99, " ")), 99)))
                        Exit For
                    End If
                Next ws
                .Close False
            End With
        End If
    Next KeyWordCell
    On Error GoTo 0
    
    Intersect(rngKeyWords.EntireRow, wsDest.Columns("E")).Value = Application.Transpose(arrDieNo)
    Intersect(rngKeyWords.EntireRow, wsDest.Columns("J")).Value = Application.Transpose(arrCures)
    
CleanExit:
    With Application
        .Calculation = lCalc
        .AutomationSecurity = lMacroSec
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    If Err.Number <> 0 Then Err.Clear
    
    Set ws = Nothing
    Set wsDest = Nothing
    Set rngFound = Nothing
    Set rngKeyWords = Nothing
    Set KeyWordCell = Nothing
    Erase arrFiles
    Erase arrDieNo
    Erase arrCures
    
End Sub

Is MIN the only unit of measurement for the Cure Time?

Update the If Instr... block to the following:

                    If InStr(1, ws.Name, "Template", vbTextCompare) > 0 Then
                        Set rngFound = ws.Cells.Find("DIE #", , xlValues, xlPart)
                        If Not rngFound Is Nothing Then
                            Select Case (InStr(1, rngFound.Offset(, 4).Text, "/", vbTextCompare) > 0)
                                Case True:  arrDieNo(arrIndex) = Trim(Replace(Replace(Replace(LCase(rngFound.Offset(, 4).Text), "hk", vbNullString), "-", vbNullString), """", vbNullString))
                                Case Else:  arrDieNo(arrIndex) = Trim(rngFound.Offset(, 4).Text)
                            End Select
                        End If
                        Set rngFound = ws.Cells.Find("CURE TIME", , xlValues, xlPart)
                        If Not rngFound Is Nothing Then arrCures(arrIndex) = CDbl(Trim(Replace(LCase(rngFound.End(xlToRight).Text), "min", vbNullString)))
                        Exit For
                    End If