Using VBA to search multiple Excel workbooks in folder

[RickWright]

Hi folks.

I have found a spreadsheet which can search on different criteria over multiple spreadsheets.

I am looking for one which can search on say 3 criteria as in "OSD" "LIV" & "ENT" and it will identify that it is in a sheet as below.

Problem is, it will identify all three search criteria even if they are in different rows. Is there any way to force it to match all criteria in a row?

Position		Product	Weight	State	Grade	PH/L	Voyage		Total
1	A	OSD	22.0	LIV	UNG	ENT	122		30
	B	HOK	R/W	PCE	UNG	ENT	120		1
		RBM	R/W	DRE	UNG	WAI	135A		2
		SSO	22.0	DRE	S	WAI	149		8
	C	SSO	22.0	DRE	M	WAI	139		4
	D	GSC	R/W	LEGS	UNG	WAI	151		48
	E	OSD	13.0	LIV	A LIB	AOT	110		31

<colgroup><col width="36" style="width:27pt" span="2"> <col width="124" style="width:93pt"> <col width="64" style="width:48pt"> <col width="68" style="width:51pt" span="6"> </colgroup><tbody>
</tbody>

Hopefully I dont muck this paste up.... This is what I am working with. Cheers. Rick

Private Function Lookup(ByVal TermToSearch As String, ByRef TargetWorkbook As Workbook) As Boolean

    If TermToSearch = "" Then
        Lookup = False
        Exit Function
    End If


    Dim c As Range


    Dim TargetSheet As Worksheet
    For Each TargetSheet In TargetWorkbook.Worksheets
        Set c = TargetSheet.Cells
        
        If PartCheckBox.Value Then
            Set c = c.Find(TermToSearch, , , xlPart, , , CaseSensitiveCheckBox.Value)
        Else
            Set c = c.Find(TermToSearch, , , xlWhole, , , CaseSensitiveCheckBox.Value)
        End If
        
        If c Is Nothing Then
            Lookup = False
        Else
            c.Show
            c.Select
            Lookup = True
            Exit Function
        End If
    Next




End Function


Private Sub AutoOpenCheckBox_Click()
    If AutoOpenCheckBox.Value Then
        AutoWriteCheckBox.Enabled = True
    Else
        AutoWriteCheckBox.Enabled = False
        AutoWriteCheckBox.Value = False
    End If
End Sub


Private Function BreakCheck()


    If BreakCheckBox.Value Then
        AutoOpenCheckBox.Enabled = True
    Else
        AutoOpenCheckBox.Enabled = False
        AutoOpenCheckBox.Value = False
        
        AutoWriteCheckBox.Enabled = False
        AutoWriteCheckBox.Value = False
    End If


End Function


Private Sub BreakCheckBox_Click()
    BreakCheck
End Sub


Private Sub CurrentDirectoryButton_Click()
    DirectorySearchBox.Value = ThisWorkbook.Path
End Sub


Private Function GetDirectory() As String


    Dim FolderName As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .AllowMultiSelect = False
        .Show
        On Error Resume Next
        FolderName = .SelectedItems(1)
        Err.Clear
        On Error GoTo 0
    
    End With


    GetDirectory = FolderName


End Function


Private Function GetSaveAs() As String


    Dim FolderName As Variant
    
    FolderName = Application.GetSaveAsFilename(InitialFileName:="Results.txt", FileFilter:="Txt File (*.txt), *.txt")
    
    If FolderName <> False Then
        GetSaveAs = FolderName
    Else
        GetSaveAs = ""
    End If
    
End Function


Private Sub ExportButton_Click()
    
    Dim Location As String
    Location = GetSaveAs()
    
    If Location = "" Then
    
    Else
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Dim oFile As Object
        Set oFile = fso.CreateTextFile(Location)
        oFile.WriteLine LocationsTextBox.Value
        oFile.Close
        Set fso = Nothing
        Set oFile = Nothing
            
    End If


End Sub


Private Sub IncludeSubfoldersCheckbox_Click()


End Sub


Private Sub OnlyBox_Change()


End Sub


Private Sub SearchForDirectoryButton_Click()
    DirectorySearchBox.Value = GetDirectory()
End Sub


Function GetUNC(strMappedDrive As String) As String


    If InStr(1, strMappedDrive, "\\") Then
    
        GetUNC = strMappedDrive
        Exit Function
    
    End If


    Dim objFso As FileSystemObject
    Set objFso = New FileSystemObject
    Dim strDrive As String
    Dim strShare As String
    'Separated the mapped letter from
    'any following sub-folders
    strDrive = objFso.GetDriveName(strMappedDrive)
    'find the UNC share name from the mapped letter
    strShare = objFso.Drives(strDrive).ShareName
    'The Replace function allows for sub-folders
    'of the mapped drive
    GetUNC = Replace(strMappedDrive, strDrive, strShare)
    Set objFso = Nothing 'Destroy the object
End Function


Private Function RetrieveFilesList(SourcePath As String, Optional ByVal IncludeSubfolders As Boolean = True) As String()
    
    
    Set MyFSO = New FileSystemObject
    Set FolderObject = MyFSO.GetFolder(GetUNC(SourcePath))
    
    If FolderObject Is Nothing Then
        
        StatusLabel.Caption = SourcePath & " was not found"
        Exit Function
    
    End If
    
    Dim SubFolderArray() As String
    
    Dim Iter As Long
    
    If IncludeSubfolders Then
    
        Dim TempFolderArray() As String
        ReDim Preserve TempFolderArray(0 To 1)
        ReDim Preserve SubFolderArray(0 To 1)
        
        Dim Offset As Long
        Dim Oldset As Long
        Dim TempIter As Long
        
        TempIter = 0
        Offset = 0
        OldOffset = 0
        
        For Each SubFolder In FolderObject.SubFolders
            TempFolderArray = RetrieveFilesList(SubFolder.Path, True)
            If UBound(TempFolderArray) > 0 Then
                
                OldOffset = Offset
                Offset = Offset + UBound(TempFolderArray)
                
                ReDim Preserve SubFolderArray(0 To Offset)
            
                TempIter = 0
                
                Do While TempIter < UBound(TempFolderArray)
                    SubFolderArray(OldOffset + TempIter) = TempFolderArray(TempIter)
                    TempIter = TempIter + 1
                Loop
            
            End If
        Next
    
        Iter = 0
        For Each NewFile In FolderObject.Files
            Iter = Iter + 1
        Next
    
        OldOffset = Offset
        Offset = Offset + Iter
        ReDim Preserve SubFolderArray(0 To Offset)
    
        TempIter = 0
        For Each NewFile In FolderObject.Files
            
            SubFolderArray(OldOffset + TempIter) = NewFile.Path
            TempIter = TempIter + 1
        Next
        
        RetrieveFilesList = SubFolderArray
    Else
    
        Dim FolderArray() As String
    
        Iter = 0
        For Each NewFile In FolderObject.Files
            Iter = Iter + 1
        Next
    
        ReDim FolderArray(0 To Iter)
    
        Iter = 0
        For Each NewFile In FolderObject.Files
            FolderArray(Iter) = NewFile.Path
            Iter = Iter + 1
        Next
        
        RetrieveFilesList = FolderArray
        
    End If
    
    Set MyFSO = Nothing
    Set FolderObject = Nothing
    
    
End Function


Private Function ToggleEverything(ByVal Target As Boolean)


    ExportButton.Enabled = Target
    BeginSearchButton.Enabled = Target
    IncludeSubfoldersCheckbox.Enabled = Target
    CurrentDirectoryButton.Enabled = Target
    SearchForDirectoryButton.Enabled = Target
    PasswordBox.Enabled = Target
    TextSearchBox.Enabled = Target
    DirectorySearchBox.Enabled = Target
    TextSearchBox2.Enabled = Target
    
    OptionButtonXOR.Enabled = Target
    OptionButtonOR.Enabled = Target
    OptionButtonBUTNOT.Enabled = Target
    OptionButtonAND.Enabled = Target
    OptionButtonNAND.Enabled = Target
    OptionButtonNEITHER.Enabled = Target
    
    PartCheckBox.Enabled = Target
    CaseSensitiveCheckBox.Enabled = Target
    
    LocationsTextBox.Enabled = Target
    
    BreakCheckBox.Enabled = Target
    AutoOpenCheckBox.Enabled = Target
    AutoWriteCheckBox.Enabled = Target
    
    'Check to sure nothing is enabled that shouldn't be
    BreakCheck


End Function


Private Function ParameterCheck(ByRef TargetWorkbook As Workbook) As Boolean


    If OptionButtonAND.Value Or OptionButtonNAND.Value Then
        If Lookup(TextSearchBox.Value, TargetWorkbook) And Lookup(TextSearchBox2.Value, TargetWorkbook) And Lookup(TextSearchBox3.Value, TargetWorkbook) Then
            ParameterCheck = OptionButtonAND.Value
            Exit Function
        End If
    ElseIf OptionButtonOR.Value Or OptionButtonNEITHER.Value Then
        If Lookup(TextSearchBox.Value, TargetWorkbook) Or Lookup(TextSearchBox2.Value, TargetWorkbook) Or Lookup(TextSearchBox3.Value, TargetWorkbook) Then
            ParameterCheck = OptionButtonOR.Value
            Exit Function
        End If
    ElseIf OptionButtonBUTNOT.Value Or OptionButtonXOR.Value Then
        If Lookup(TextSearchBox.Value, TargetWorkbook) And Not Lookup(TextSearchBox2.Value, TargetWorkbook) Then
            ParameterCheck = True
            Exit Function
        End If
        If OptionButtonXOR.Value Then
            If Lookup(TextSearchBox2.Value, TargetWorkbook) And Not Lookup(TextSearchBox.Value, TargetWorkbook) Then
                ParameterCheck = True
                Exit Function
            End If
        End If
    End If


    ParameterCheck = False


End Function


Private Function CheckRadioValues() As Boolean


    CheckRadioValues = False
    If OptionButtonXOR.Value Or OptionButtonOR.Value Or OptionButtonAND.Value Or OptionButtonNAND.Value Or OptionButtonNEITHER.Value Or OptionButtonBUTNOT.Value Then
        CheckRadioValues = True
    End If


End Function


Private Function PreflightCheck() As Boolean
    
    PreflightCheck = True
    
    If TextSearchBox.Value = "" And TextSearchBox2.Value = "" Then
        MsgBox "You must specify a term or value to search!"
        PreflightCheck = False
        Exit Function
    End If
    
    If DirectorySearchBox.Value = "" Then
        MsgBox "You must specify a directory to search in!"
        PreflightCheck = False
        Exit Function
    End If
    
    If Not CheckRadioValues() Then
        OptionButtonOR.Value = True
    End If


End Function


Private Function OnlyBoxCheck(ByRef Filename As String) As Boolean
    OnlyBoxCheck = False
    
    If OnlyBox.Value = "" Then
        OnlyBoxCheck = True
    ElseIf InStr(1, Filename, OnlyBox.Value) > 0 Then
        OnlyBoxCheck = True
    End If
    
End Function


Private Sub BeginSearchButton_Click()


    'Check that all needed variables are supplied
    If Not PreflightCheck() Then
    
        Exit Sub
    
    End If


    Dim FolderArray() As String
        
    'Get the list of files
    FolderArray = RetrieveFilesList(DirectorySearchBox.Value, IncludeSubfoldersCheckbox.Value)
    
    Dim Iter As Long
    Iter = 0


    
    Dim TargetWorkbook As Workbook
    
    StatusLabel.Caption = "Beginning search..."
    LocationsTextBox.Value = ""
    
    ToggleEverything False
    
    'Identif
    Dim CheckFilename As String
    CheckFilename = Replace(ThisWorkbook.FullName, Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\")), "")


    'Get size of the FolderArray once so we don't have to recalculate it at every pass
    Dim PermFolderArrayUBound As Long
    PermFolderArrayUBound = UBound(FolderArray)


    'Iterate through each file found
    Do While Iter < PermFolderArrayUBound
        
        StatusLabel.Caption = "Checking file: " & FolderArray(Iter)
        
        If InStr(1, FolderArray(Iter), CheckFilename) > 0 Then
            FolderArray(Iter) = ""
        End If
        
        'Lets not annoy the user with things constantly appearing/disappearing
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        If InStr(1, FolderArray(Iter), ".xls") > 0 Or InStr(1, FolderArray(Iter), ".xlsm") > 0 Then
            
            StatusLabel.Caption = "Scanning Workbook: " & FolderArray(Iter) & vbNewLine & vbNewLine & "File: " & (Iter + 1) & " out of " & (PermFolderArrayUBound + 1) & " files."
            
            If OnlyBoxCheck(FolderArray(Iter)) Then
                'Lets check if we have a password supplied
                If PasswordBox.Value = "" Then
                
    
                    On Error Resume Next
                    Set TargetWorkbook = Application.Workbooks.Open(FolderArray(Iter), 2, True)
                
                    If Err.Number <> 0 Then
                        LocationsTextBox.Value = LocationsTextBox.Value & "ERROR: " & Err.Number & ". Could not open: " & Replace(FolderArray(Iter), GetUNC(DirectorySearchBox.Value), "") & vbNewLine
                        Err.Clear
                    End If
                
                    If Not TargetWorkbook Is Nothing Then
                        If ParameterCheck(TargetWorkbook) Then
                            
                            LocationsTextBox.Value = LocationsTextBox.Value & "Matching file: " & Replace(FolderArray(Iter), GetUNC(DirectorySearchBox.Value), "") & vbNewLine
                            
                            'If we encounter the first correct match and the user tells us to break, then do it
                            If BreakCheckBox.Value Then
                                'Allow the user to see and inteact with stuff
                                Application.ScreenUpdating = True
                                Application.EnableEvents = True
                                
                                'Check if we're auto opening
                                If AutoOpenCheckBox.Value Then
                                    'If auto, does the user want to  be able to edit the spreadsheet?
                                    If AutoWriteCheck.Value Then
                                        'Close it from read only and open up in write mode
                                        TargetWorkbook.Close False
                                        Set TargetWorkbook = Application.Workbooks.Open(FolderArray(Iter), 2, False)
                                    End If
                                Else
                                    TargetWorkbook.Close False
                                End If
                                
                                Set TargetWorkbook = Nothing
                                ToggleEverything True
                                Exit Sub
                            End If
                            
                        End If
                    End If
                    
                
                    TargetWorkbook.Close False
                    Set TargetWorkbook = Nothing
                    On Error GoTo 0
                Else
                
                    On Error Resume Next
                    Set TargetWorkbook = Application.Workbooks.Open(FolderArray(Iter), 2, True, , PasswordBox.Value)
                    
                    If Err.Number = 1004 Then
                        LocationsTextBox.Value = LocationsTextBox.Value & "ERROR: Password Mismatch. Could not open: " & Replace(FolderArray(Iter), GetUNC(DirectorySearchBox.Value), "") & vbNewLine
                        Err.Clear
                    End If
                
                    If Not TargetWorkbook Is Nothing Then
                        If ParameterCheck(TargetWorkbook) Then
                            
                            LocationsTextBox.Value = LocationsTextBox.Value & "Matching file: " & Replace(FolderArray(Iter), GetUNC(DirectorySearchBox.Value), "") & vbNewLine
                            If BreakCheckBox.Value Then
                                Application.ScreenUpdating = True
                                Application.EnableEvents = True
                                
                                If AutoOpenCheckBox.Value Then
                                    If AutoWriteCheck.Value Then
                                        'Close it from read only and open up in write mode
                                        TargetWorkbook.Close False
                                        Set TargetWorkbook = Application.Workbooks.Open(FolderArray(Iter), 2, False, , PasswordBox.Value)
                                    End If
                                Else
                                    TargetWorkbook.Close False
                                End If
                                
                                Set TargetWorkbook = Nothing
                                ToggleEverything True
                                Exit Sub
                            End If
                        End If
                    End If
                    
                    TargetWorkbook.Close False
                    Set TargetWorkbook = Nothing
                    On Error GoTo 0
                End If
            End If
        
        End If
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        
        Iter = Iter + 1
        
    Loop
    
    If LocationsTextBox.Value = "" Then
        LocationsTextBox.Value = "None found (yet)."
    End If
    
    ToggleEverything True
    
    StatusLabel.Caption = "Finished. Awaiting input."
    
    
End Sub

 

[RickWright]

Forgot to mention. When it goes through doing a search, it is looking through 147 different workbooks, and some of them with multi sheets. And for even more fun they are in 6 folders.