Searching multiple spreadsheets

Last Edited By Krjb Donovan
Last Updated: Mar 05, 2014 09:54 PM GMT

QuestionEdit

I saw a macro you wrote for someone on how to search all spreadsheets in all workbooks in a dir for a string. This code is included below. I would like to do something very similar, however in a new workbook, i would like the macro to search through all worksheets in workbooks in the dir, for a string in the top of the new workbook. So after it finishes searching for the string in A1 and fills out the columns below it moves to B1.

Thank you for your time. Tim.

Sub loopfiles() Dim sName As String, sPath As String Dim sh As Worksheet, rw As Long, sh1 As Worksheet Dim bk As Workbook Set sh = ActiveSheet rw = 2 sPath = ThisWorkbook.Path

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

sName = Dir(sPath & "*.xls") Do While sName <> "" If LCase(sName) <> LCase(ThisWorkbook.Name) Then

Set bk = Workbooks.Open(sPath & sName)
For Each sh1 In ActiveWorkbook.Worksheets
 If Application.CountIf(sh1.Cells, "*Amaranthus Sp*") > 0 Then
         ' the sheet contains "Amaranthus Sp"
    sh.Cells(rw, 1) = bk.Name
    sh.Cells(rw, 2) = sh1.Name
    rw = rw + 1
 End If
Next
bk.Close SaveChanges:=False

End If sName = Dir() Loop End Sub

AnswerEdit

Tim,

Sub loopfiles() Dim sName As String, sPath As String Dim sh As Worksheet, rw As Long, sh1 As Worksheet Dim bk As Workbook, r As Range, cell As Range Set sh = ActiveSheet

sPath = ThisWorkbook.Path

If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

Set r = sh.Range("A1:Z1") ' list ofto lookup

rw = 4

For Each cell In r

 sh.Cells(rw, 1).Value = "Word to find:"
 sh.Cells(rw, 2).Value = cell
 rw = rw + 1

sName = Dir(sPath & "*.xls") Do While sName <> "" If LCase(sName) <> LCase(ThisWorkbook.Name) Then Set bk = Workbooks.Open(sPath & sName) For Each sh1 In ActiveWorkbook.Worksheets

If Application.CountIf(sh1.Cells, "*" & cell.Text & "*") > 0 Then
        ' the sheet contains "Amaranthus Sp"
   sh.Cells(rw, 1) = bk.Name
   sh.Cells(rw, 2) = sh1.Name
   rw = rw + 1
End If

Next bk.Close SaveChanges:=False End If sName = Dir() Loop Next End Sub

Advertisement

©2024 eLuminary LLC. All rights reserved.