Hi
I am trying to search multiple work books to find data and summarise on on sheet. IE I have created a quotation workbook which has the main sheet called quote form. What I want to do is to run a macro that will search all my quotes and pick out certain data IE in example below CR-2AF. I found the attached example which sort of does it but it searches all the sheets in all the quotes I just want it to search the Sheet called Quote form. Any help appreciated please. I also would like to create input box too so as not to have to put item (CR-2AF in VBA code)
Thank you
Paul
I am trying to search multiple work books to find data and summarise on on sheet. IE I have created a quotation workbook which has the main sheet called quote form. What I want to do is to run a macro that will search all my quotes and pick out certain data IE in example below CR-2AF. I found the attached example which sort of does it but it searches all the sheets in all the quotes I just want it to search the Sheet called Quote form. Any help appreciated please. I also would like to create input box too so as not to have to put item (CR-2AF in VBA code)
VBA Code:
Public Sub searchText()
Dim FSO As Object
Dim folder As Object, subfolder As Object
Dim wb As Object
Dim ws As Worksheet
searchList = Array("CR2-AF") 'define the list of text you want to search, case insensitive
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\Users\paulh\OneDrive - xxxxLimited\Quote 2020" 'define the path of the folder that contains the workbooks
Set folder = FSO.GetFolder(folderPath)
Dim thisWbWs, newWS As Worksheet
'Create summary worksheet if not exist
For Each thisWbWs In ActiveWorkbook.Worksheets
If wsExists("summary") Then
counter = 1
End If
Next thisWbWs
If counter = 0 Then
Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
With newWS
.Name = "summary1"
.Range("A1").Value = "Target Keyword"
.Range("B1").Value = "Workbook"
.Range("C1").Value = "Worksheet"
.Range("D1").Value = "Address"
.Range("E1").Value = "Cell Value"
End With
End If
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
'Check each workbook in main folder
For Each wb In folder.Files
If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
Set masterWB = Workbooks.Open(wb)
For Each ws In masterWB.Worksheets
For Each Rng In ws.UsedRange
For Each i In searchList
If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then 'vbTextCompare means case insensitive.
nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
With ThisWorkbook.Sheets("summary")
.Range("A" & nextRow).Value = i
.Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
.Range("C" & nextRow).Value = ws.Name
.Range("D" & nextRow).Value = Rng.Address
.Range("E" & nextRow).Value = Rng.Value
End With
End If
Next i
Next Rng
Next ws
ActiveWorkbook.Close True
End If
Next
'Check each workbook in sub folders
For Each subfolder In folder.SubFolders
For Each wb In subfolder.Files
If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
Set masterWB = Workbooks.Open(wb)
For Each ws In masterWB.Worksheets
For Each Rng In ws.UsedRange
For Each i In searchList
If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then
nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
With ThisWorkbook.Sheets("summary")
.Range("A" & nextRow).Value = i
.Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
.Range("C" & nextRow).Value = ws.Name
.Range("D" & nextRow).Value = Rng.Address
.Range("E" & nextRow).Value = Rng.Value
End With
End If
Next i
Next Rng
Next ws
ActiveWorkbook.Close True
End If
Next
Next
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With
ThisWorkbook.Sheets("summary").Cells.Select
ThisWorkbook.Sheets("summary").Cells.EntireColumn.AutoFit
ThisWorkbook.Sheets("summary").Range("A1").Select
End Sub
Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0
End Function
Paul
Last edited by a moderator: