Challenge Question of the week 10 Points !
Posted by Saadi on January 26, 2002 12:55 PM
Hi,
Summary:
I need to check if a certain word is a value in one of many excel workbooks.
For instance, I have three files on my machine as follows:
accounts_above_threshold.xls
accounts_below_threshold.xls
accounts_notsubject_threshold.xls
Now in some way I get the computer to look at all the values of all the cells in all three workbooks and see if one of the cells contains an account number I supply, i.e., 200111.
Using Windows search files and folders function " containing text " doesn't seem to work.
Thanks for your help !
Saadi
Posted by Jack in the UK on January 26, 2002 3:09 PM
Hi Saadi-
Account eh! My home ground finance and debt is my field and Excel + bespoke
OK if you data is in table array form, accounts always are.
Select all sheet together and find the accout number you wich as normal ie 200111, to do this select first sheet right click on the tab a box appears and click select all, now press and hod CTRL and press F a box apear your know find as 2000111 and it will search all sheets, manual i know but will work OK
Let me know as i say if Accounts/finance/computer software company might be avble to help more.
Rdgs
Jack in the UK
Posted by Ivan F Moala on January 26, 2002 6:48 PM
If you are doing this reguarly then I would suggest 2 things
1) using a macro
2) placing all the files to check in a seperate
Dir
Try this code to see if it helps.
NB: Directory it searches is hard coded change
it to suit
Option Explicit
Dim sDir As String
Dim iFilecount As Integer
Dim FileSearch
Dim Sh As Worksheet
Dim SrchData As Range
Dim oCell As Range
Dim SearchValue As Double
Dim ResultsSh As Worksheet
Dim dIndexCounter As Double
Sub SearchFiles()
dIndexCounter = 1
sDir = "C:\AData"
Set FileSearch = Application.FileSearch
Application.ScreenUpdating = False
SearchValue = Application.InputBox("Enter value to search for", Type:=1)
If SearchValue = 0 Then Exit Sub
AddSheet
With FileSearch
.LookIn = sDir
.Filename = "*.xls"
If .Execute > 0 Then
For iFilecount = 1 To .FoundFiles.Count
On Error GoTo ErrHere
Workbooks.Open Filename:=.FoundFiles(iFilecount)
sDataInWBk
ActiveWorkbook.Close False
Next iFilecount
ResultsSh.Columns("A:D").Columns.AutoFit
Else
MsgBox "There were no " & .Filename & " found in " & sDir
End If
End With
Set ResultsSh = Nothing
Application.ScreenUpdating = False
MsgBox "Job completed successfully !", vbSystemModal + vbInformation
Exit Sub
ErrHere:
MsgBox Err.Number & Err.Description
End Sub
Sub AddSheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Search_Results").Delete
On Error GoTo 0
Sheets.Add
With ActiveSheet
.Name = "Search_Results"
.Range("A1") = Now & " - Search For >"
.Range("A2") = "File Name"
.Range("B1") = SearchValue
.Range("B2") = "SheetName"
.Range("C1") = "Found:="
.Range("D1") = "=COUNTA(C3:C65536)"
.Range("C2") = "Address"
.Range("D2") = "Value"
.Range("A1:D2").HorizontalAlignment = xlCenter
.Range("A1:D2").Font.Bold = True
End With
Set ResultsSh = ActiveSheet
Application.DisplayAlerts = True
End Sub
Sub sDataInWBk()
'Search for value in Data Workbook
'
On Error Resume Next
For Each Sh In ActiveWorkbook.Sheets
Set SrchData = Sh.[A1].SpecialCells(2, 3)
If Err Then GoTo skip
For Each oCell In SrchData
If oCell = SearchValue Then
'Place results in columns
ResultsSh.Cells(dIndexCounter + 2, 1) = ActiveWorkbook.FullName
ResultsSh.Cells(dIndexCounter + 2, 2) = Sh.Name
ResultsSh.Cells(dIndexCounter + 2, 3) = oCell.Address
ResultsSh.Cells(dIndexCounter + 2, 4) = oCell
dIndexCounter = dIndexCounter + 1
End If
Next oCell
skip: Err.Clear
Set SrchData = Nothing
Next Sh
End Sub
HTH
Ivan
Posted by Ivan F Moala on January 26, 2002 8:09 PM
code amendment
Amended code;
Option Explicit
Dim sDir As String
Dim iFilecount As Integer
Dim FileSearch
Dim Sh As Worksheet
Dim SrchData As Range
Dim oCell As Range
Dim SearchValue As Double
Dim ResultsSh As Worksheet
Dim dIndexCounter As Double
Sub SearchFiles()
dIndexCounter = 1
SearchValue = Application.InputBox("Enter value to search for", Type:=1)
If SearchValue = 0 Then Exit Sub
Application.ScreenUpdating = False
AddSheet
sDir = "C:\AData"
Set FileSearch = Application.FileSearch
With FileSearch
.LookIn = sDir
.Filename = "*.xls"
If .Execute > 0 Then
For iFilecount = 1 To .FoundFiles.Count
On Error GoTo ErrHere
Workbooks.Open Filename:=.FoundFiles(iFilecount)
sDataInWBk
ActiveWorkbook.Close False
Next iFilecount
ResultsSh.Columns("A:D").Columns.AutoFit
Else
MsgBox "There were no " & .Filename & " found in " & sDir
End
End If
End With
Set ResultsSh = Nothing
Application.ScreenUpdating = True
MsgBox "Job completed successfully !", vbSystemModal + vbInformation
Exit Sub
ErrHere:
MsgBox Err.Number & Err.Description
End Sub
Sub AddSheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Search_Results").Delete
On Error GoTo 0
Sheets.Add
With ActiveSheet
.Name = "Search_Results"
.Range("A1") = Now & " - Search For >"
.Range("A2") = "File Name"
.Range("B1") = SearchValue
.Range("B2") = "SheetName"
.Range("C1") = "Found:="
.Range("D1") = "=COUNTA(C3:C65536)"
.Range("C2") = "Address"
.Range("D2") = "Value"
.Range("A1:D2").HorizontalAlignment = xlCenter
.Range("A1:D2").Font.Bold = True
End With
Set ResultsSh = ActiveSheet
Application.DisplayAlerts = True
End Sub
Sub sDataInWBk()
'Search for value in Data Workbook
'
On Error Resume Next
For Each Sh In ActiveWorkbook.Sheets
Set SrchData = Sh.[A1].SpecialCells(2, 3)
If Err Then GoTo skip
For Each oCell In SrchData
If oCell = SearchValue Then
'Place results in columns
ResultsSh.Cells(dIndexCounter + 2, 1) = ActiveWorkbook.FullName
ResultsSh.Cells(dIndexCounter + 2, 2) = Sh.Name
ResultsSh.Cells(dIndexCounter + 2, 3) = oCell.Address
ResultsSh.Cells(dIndexCounter + 2, 4) = oCell
dIndexCounter = dIndexCounter + 1
End If
Next oCell
skip: Err.Clear
Set SrchData = Nothing
Next Sh
End Sub
Posted by Ivan from Jack in The UK on January 27, 2002 2:31 AM
Cool code! hope you dont mind if i use this one as well! Jack [NT]
Posted by Paul on January 27, 2002 5:15 AM
Nice Code, but..
The code also returns all text in the workbooks that it searches, how can this be fixed, also is there anyway to modify it to search for text, it seams to just search for numbers, I am using excel '97. Thanks
Posted by Ivan F Moala on January 27, 2002 2:42 PM
Re: Nice Code, but..
Have amended code....Please test....
Option Explicit
Dim sDir As String 'Search Dir
Dim iFilecount As Integer 'File count
Dim FileSearch 'Applications Fileserach function
Dim Sh As Worksheet '
Dim SrchData As Range '
Dim oCell As Range 'Sheet cells to search
Dim SearchValue 'Searching For
Dim ResultsSh As Worksheet 'Results sheet
Dim dIndexCounter As Double 'Indexcounter
Dim vTypeSC 'Specialcells Type
Dim sTypeInput 'InputBox Type
Dim sTypeInputStr As String '
Dim ExactMatch As Boolean 'Use patern matching or Exact match
Sub SearchFiles()
Dim Msg As String
dIndexCounter = 1
'Get match Type
ExactMatch = MatchType
Msg = vbCr & "Your current search criteria:" & vbCr & "- Exact Match=" & ExactMatch & vbCr
'Get search Type
SearchType
Msg = Msg & "- Search Type:=" & sTypeInputStr
SearchValue = Application.InputBox("Enter value to search for" & vbCr & Msg, Type:=sTypeInput)
If SearchValue = "" Or SearchValue = 0 Then Exit Sub
Application.ScreenUpdating = False
AddSheet
'Change this to your Dir
'If you want a dynamic way to select the Dir
'Then repost and I'll provide the code
sDir = "C:\" '\AData"
Set FileSearch = Application.FileSearch
With FileSearch
.LookIn = sDir
.Filename = "*.xls"
If .Execute > 0 Then
For iFilecount = 1 To .FoundFiles.Count
On Error GoTo ErrHere
Workbooks.Open Filename:=.FoundFiles(iFilecount)
If Not ExactMatch Then
PatternMatch
Else
sDataInWBk
End If
ActiveWorkbook.Close False
Next iFilecount
ResultsSh.Columns("A:D").Columns.AutoFit
Else
MsgBox "There were no files of Type:=[" & .Filename & "]" & " found in " & sDir
End
End If
End With
Set ResultsSh = Nothing
Application.ScreenUpdating = True
MsgBox "Job completed successfully !", vbSystemModal + vbInformation
Exit Sub
ErrHere:
MsgBox Err.Number & Err.Description
End Sub
Sub AddSheet()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Search_Results").Delete
On Error GoTo 0
Sheets.Add
With ActiveSheet
.Name = "Search_Results"
.Range("A1") = Now & " - Search For >"
.Range("A2") = "File Name"
.Range("B1") = SearchValue
.Range("B2") = "SheetName"
.Range("C1") = "Found:="
.Range("D1") = "=COUNTA(C3:C65536)"
.Range("C2") = "Address"
.Range("D2") = "Value"
.Range("A1:D2").HorizontalAlignment = xlCenter
.Range("A1:D2").Font.Bold = True
End With
Set ResultsSh = ActiveSheet
Application.DisplayAlerts = True
End Sub
Sub sDataInWBk()
'Search for Exact value/String in Data Workbook
On Error Resume Next
For Each Sh In ActiveWorkbook.Sheets
Set SrchData = Sh.[A1].SpecialCells(2, vTypeSC)
If Err Then GoTo skip
For Each oCell In SrchData
If oCell = SearchValue Then
'Place results in columns
With ResultsSh
.Cells(dIndexCounter + 2, 1) = ActiveWorkbook.FullName
.Cells(dIndexCounter + 2, 2) = Sh.Name
.Cells(dIndexCounter + 2, 3) = oCell.Address
.Cells(dIndexCounter + 2, 4) = oCell
End With
dIndexCounter = dIndexCounter + 1
End If
Next oCell
skip: Err.Clear
Set SrchData = Nothing
Next Sh
End Sub
Sub PatternMatch()
'Search for partial match value/String in Data Workbook
Dim FoundFirst As String
Dim OrigStBar
OrigStBar = Application.DisplayStatusBar
On Error Resume Next
For Each Sh In ActiveWorkbook.Sheets
Set SrchData = Sh.[A1].SpecialCells(2, vTypeSC)
If Err Then GoTo skip
Set oCell = SrchData.Find(What:=SearchValue, After:=SrchData(1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If oCell Is Nothing Then GoTo skip
FoundFirst = oCell.Address
Do
Set oCell = SrchData.Find(What:=SearchValue, After:=oCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Application.DisplayStatusBar = True
Application.StatusBar = "Searching:" & ActiveWorkbook.FullName & Sh.Name & oCell.Address & "|" & dIndexCounter
With ResultsSh
.Cells(dIndexCounter + 2, 1) = ActiveWorkbook.FullName
.Cells(dIndexCounter + 2, 2) = Sh.Name
.Cells(dIndexCounter + 2, 3) = oCell.Address
.Cells(dIndexCounter + 2, 4) = oCell
End With
dIndexCounter = dIndexCounter + 1
Loop Until oCell.Address = FoundFirst
skip: Err.Clear
Set SrchData = Nothing
Set oCell = Nothing
Next Sh
Application.StatusBar = False
Application.DisplayStatusBar = OrigStBar
End Sub
Sub SearchType()
'1 = xl constants|Numbers only
'2 = xl constants|Text
'3 = xl constants|Numbers&Text
Invalid:
vTypeSC = Application.InputBox("Type in;" & vbCrLf & vbCrLf & _
"[1] = Numbers only" & vbCrLf & _
"[2] = Text only" & vbCrLf & _
"[3] = Numbers and Text", "Search Type", Type:=1)
If vTypeSC = False Then End
Select Case vTypeSC
Case 1
sTypeInput = 1
sTypeInputStr = "Numbers only"
Case 2
sTypeInput = 2
sTypeInputStr = "Text only"
Case 3
sTypeInput = 2
sTypeInputStr = "Numbers and Text"
Case Else
GoTo Invalid
End Select
End Sub
Function MatchType() As Boolean
Dim Ans As String
Ans = MsgBox("Press Key for Match Type;" & vbCrLf & vbCrLf & _
"[Yes] = Exact Match" & vbCrLf & _
"[No] = Contains String/Value" & vbCrLf & _
"[Cancel] = Stop search", vbYesNoCancel)
If Ans = vbCancel Then End
MatchType = IIf(Ans = vbYes, True, False)
End Function
Posted by Ivan F Moala on January 27, 2002 2:45 PM
Re: Cool code! hope you dont mind if i use this one as well! Jack [NT]
Hi jack
Try the 2nd amended code as this give you
more options in the search type eg Numbers only
text only, Numbers and Text PLUS either search
for Exact match or partial.
Ivan
Posted by Saadi on January 29, 2002 6:17 AM
Re: Cool code! hope you dont mind if i use this one as well! Jack [NT]
Ivan,
This is great ! One extra challenge, if some of the excel spreadsheets are password protected in order to modify, does this pose a problem (hence why my windows search function failed)
Thank you so much for your time.
Saadi
