RickWright
New Member
- Joined
- May 14, 2017
- Messages
- 2
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?
[TABLE="width: 668"]
<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>[TR]
[TD="class: xl16, width: 36"]Position[/TD]
[TD="class: xl17, width: 36"][/TD]
[TD="class: xl17, width: 124"]Product[/TD]
[TD="class: xl17, width: 64"]Weight[/TD]
[TD="class: xl17, width: 68"]State[/TD]
[TD="class: xl17, width: 68"]Grade[/TD]
[TD="class: xl17, width: 68"]PH/L[/TD]
[TD="class: xl17, width: 68"]Voyage[/TD]
[TD="class: xl23, width: 68"][/TD]
[TD="class: xl17, width: 68"]Total[/TD]
[/TR]
[TR]
[TD="class: xl80, width: 668, colspan: 10"][/TD]
[/TR]
[TR]
[TD="class: xl24"]1[/TD]
[TD="class: xl25"]A[/TD]
[TD="class: xl26"]OSD[/TD]
[TD="class: xl27"]22.0[/TD]
[TD="class: xl25"]LIV[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl27"]ENT[/TD]
[TD="class: xl27"]122[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]30[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"]B[/TD]
[TD="class: xl26"]HOK[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]PCE[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]ENT[/TD]
[TD="class: xl25"]120[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]1[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"][/TD]
[TD="class: xl26"]RBM[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]135A[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]2[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"][/TD]
[TD="class: xl26"]SSO[/TD]
[TD="class: xl27"]22.0[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl27"]S[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]149[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]8[/TD]
[/TR]
[TR]
[TD="class: xl32"][/TD]
[TD="class: xl25"]C[/TD]
[TD="class: xl26"]SSO[/TD]
[TD="class: xl25"]22.0[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl25"]M[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]139[/TD]
[TD="class: xl32"][/TD]
[TD="class: xl25"]4[/TD]
[/TR]
[TR]
[TD="class: xl32"][/TD]
[TD="class: xl25"]D[/TD]
[TD="class: xl26"]GSC[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]LEGS[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]151[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]48[/TD]
[/TR]
[TR]
[TD="class: xl25"][/TD]
[TD="class: xl25"]E[/TD]
[TD="class: xl26"]OSD[/TD]
[TD="class: xl27"]13.0[/TD]
[TD="class: xl25"]LIV[/TD]
[TD="class: xl27"]A LIB[/TD]
[TD="class: xl25"]AOT[/TD]
[TD="class: xl25"]110[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]31[/TD]
[/TR]
</tbody>[/TABLE]
Hopefully I dont muck this paste up.... This is what I am working with. Cheers. Rick
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?
[TABLE="width: 668"]
<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>[TR]
[TD="class: xl16, width: 36"]Position[/TD]
[TD="class: xl17, width: 36"][/TD]
[TD="class: xl17, width: 124"]Product[/TD]
[TD="class: xl17, width: 64"]Weight[/TD]
[TD="class: xl17, width: 68"]State[/TD]
[TD="class: xl17, width: 68"]Grade[/TD]
[TD="class: xl17, width: 68"]PH/L[/TD]
[TD="class: xl17, width: 68"]Voyage[/TD]
[TD="class: xl23, width: 68"][/TD]
[TD="class: xl17, width: 68"]Total[/TD]
[/TR]
[TR]
[TD="class: xl80, width: 668, colspan: 10"][/TD]
[/TR]
[TR]
[TD="class: xl24"]1[/TD]
[TD="class: xl25"]A[/TD]
[TD="class: xl26"]OSD[/TD]
[TD="class: xl27"]22.0[/TD]
[TD="class: xl25"]LIV[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl27"]ENT[/TD]
[TD="class: xl27"]122[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]30[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"]B[/TD]
[TD="class: xl26"]HOK[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]PCE[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]ENT[/TD]
[TD="class: xl25"]120[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]1[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"][/TD]
[TD="class: xl26"]RBM[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]135A[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]2[/TD]
[/TR]
[TR]
[TD="class: xl24"][/TD]
[TD="class: xl25"][/TD]
[TD="class: xl26"]SSO[/TD]
[TD="class: xl27"]22.0[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl27"]S[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]149[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]8[/TD]
[/TR]
[TR]
[TD="class: xl32"][/TD]
[TD="class: xl25"]C[/TD]
[TD="class: xl26"]SSO[/TD]
[TD="class: xl25"]22.0[/TD]
[TD="class: xl25"]DRE[/TD]
[TD="class: xl25"]M[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]139[/TD]
[TD="class: xl32"][/TD]
[TD="class: xl25"]4[/TD]
[/TR]
[TR]
[TD="class: xl32"][/TD]
[TD="class: xl25"]D[/TD]
[TD="class: xl26"]GSC[/TD]
[TD="class: xl27"]R/W[/TD]
[TD="class: xl25"]LEGS[/TD]
[TD="class: xl27"]UNG[/TD]
[TD="class: xl25"]WAI[/TD]
[TD="class: xl25"]151[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]48[/TD]
[/TR]
[TR]
[TD="class: xl25"][/TD]
[TD="class: xl25"]E[/TD]
[TD="class: xl26"]OSD[/TD]
[TD="class: xl27"]13.0[/TD]
[TD="class: xl25"]LIV[/TD]
[TD="class: xl27"]A LIB[/TD]
[TD="class: xl25"]AOT[/TD]
[TD="class: xl25"]110[/TD]
[TD="class: xl25"][/TD]
[TD="class: xl25"]31[/TD]
[/TR]
</tbody>[/TABLE]
Hopefully I dont muck this paste up.... This is what I am working with. Cheers. Rick
Code:
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