I need a macro to search all the excel sheets in the folder

Hi,

I need a macro to search all the excel sheets in the folder.And get me the data i enter in the box .And copy the whole line if found.
A macro which will ask the data to be found and get the whole data if found to a new sheet.
Regards
Sharath
LVL 11
bsharathAsked:
Who is Participating?
 
Hitesh ManglaniConnect With a Mentor Commented:
'ok try this
Sub FindFile()
    Dim str1 As String
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\newfolder", "*.*", False, str1
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean, searchvalue As String)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Static s2row As Integer
    Dim ws As Workbook

    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           If InStr(1, strFileName, ".xls", vbTextCompare) > 0 Then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For j = 1 To ws.Sheets(i).UsedRange.Rows.Count
                          For k = 1 To ws.Sheets(i).UsedRange.Columns.Count
                            If UCase((ws.Sheets(i).Cells(j, k).Value)) = UCase(searchvalue) Then
                               ws.Sheets(i).Rows(j).Copy Destination:=ActiveWorkbook.Sheets(2).Rows(s2row+1)
                                  s2row = s2row + 1
                              End If
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
      End If
       strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound, searchvalue
    Next i
End Sub


0
 
Hitesh ManglaniCommented:
Try this macro
Sub FindFile()
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\MyPath", "*.*", False
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Dim s2row as Integer
    Dim ws as WorkBook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           if inStr(1,strFileName,".xls",vbtextcompare)>0 then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For i=1 to Sheet1.Usedrange.Rows.Count
                          For j=1 to Sheet1.Usedrange.Columns.Count
                            if UCase(Sheet1.Cells(i,j)) = UCase(str1) then
                               Sheet1.Rows(i).Copy Destination := ActiveWorkBook.Sheets(2).Rows(s2row)
                                  s2row = s2row +1
                              End if  
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
        strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound
    Next i
End Sub
0
 
Hitesh ManglaniCommented:
Sorry try this
Try this macro
Sub FindFile()
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\MyPath", "*.*", False
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Dim s2row as Integer
    Dim ws as WorkBook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           if inStr(1,strFileName,".xls",vbtextcompare)>0 then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For i=1 to ws.Sheets(i).Usedrange.Rows.Count
                          For j=1 to ws.Sheets(i).Usedrange.Columns.Count
                            if UCase(ws.Sheets(i).Cells(i,j)) = UCase(str1) then
                               ws.Sheets(i).Rows(i).Copy Destination := ActiveWorkBook.Sheets(2).Rows(s2row)
                                  s2row = s2row +1
                              End if  
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
        strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound
    Next i
End Sub
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
Hitesh ManglaniCommented:
just one more  change
put str1 = InputBox("SearchValue") in the FindFiles3 procedure befor the line s2row = s2row + 1

let me know if any problem
0
 
bsharathAuthor Commented:
Get procedure error.
Can you post the full code.
0
 
Hitesh ManglaniCommented:
This will work

Sub FindFile()
    Dim str1 As String
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\cvp", "*.*", False, str1
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean, searchvalue As String)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Static s2row As Integer
    Dim ws As Workbook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           If InStr(1, strFileName, ".xls", vbTextCompare) > 0 Then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For j = 1 To ws.Sheets(i).UsedRange.Rows.Count
                          For k = 1 To ws.Sheets(i).UsedRange.Columns.Count
                            If UCase(ws.Sheets(i).Cells(j, k)) = UCase(searchvalue) Then
                               ws.Sheets(i).Rows(j).Copy Destination:=ActiveWorkbook.Sheets(2).Rows(s2row)
                                  s2row = s2row + 1
                              End If
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
      End If
       strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound, searchvalue
    Next i
End Sub

0
 
bsharathAuthor Commented:
Should i modify any thing in the script and when it is asking mne to enter data.What should i enter.
0
 
Hitesh ManglaniCommented:
just modify the path in this line to your desired path
FindFiles3 "C:\cvp", "*.*", False, str1

and the data to be entered is the search value

0
 
Hitesh ManglaniCommented:
did u try it?
0
 
bsharathAuthor Commented:
I het error code 13
Error in this line while clicked debug
Set ws = GetObject(strFolder & "\" & strFileName)
0
 
Hitesh ManglaniCommented:
what is your path can you paste your exact macro?
0
 
bsharathAuthor Commented:
Sub FindFile()
    Dim str1 As String
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\Files", "*.*", False, str1
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean, searchvalue As String)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Static s2row As Integer
    Dim ws As Workbook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           If InStr(1, strFileName, ".xls", vbTextCompare) > 0 Then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For j = 1 To ws.Sheets(i).UsedRange.Rows.Count
                          For k = 1 To ws.Sheets(i).UsedRange.Columns.Count
                            If UCase(ws.Sheets(i).Cells(j, k)) = UCase(searchvalue) Then
                               ws.Sheets(i).Rows(j).Copy Destination:=ActiveWorkbook.Sheets(2).Rows(s2row)
                                  s2row = s2row + 1
                              End If
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
      End If
       strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound, searchvalue
    Next i
End Sub

In C:\files i have 3 excel files.In which each file has name Sharath in it.
In the excel when i search for Sharath
I get run time error 13
0
 
bsharathAuthor Commented:
Debug error
If UCase(ws.Sheets(i).Cells(j, k)) = UCase(searchvalue) Then
0
 
Hitesh ManglaniCommented:
Try this
Sub FindFile()
    Dim str1 As String
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\Files", "*.*", False, str1
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean, searchvalue As String)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Static s2row As Integer
    Dim ws As Workbook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           If InStr(1, strFileName, ".xls", vbTextCompare) > 0 Then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For j = 1 To ws.Sheets(i).UsedRange.Rows.Count
                          For k = 1 To ws.Sheets(i).UsedRange.Columns.Count
                            If UCase(str(ws.Sheets(i).Cells(j, k))) = UCase(searchvalue) Then
                               ws.Sheets(i).Rows(j).Copy Destination:=ActiveWorkbook.Sheets(2).Rows(s2row)
                                  s2row = s2row + 1
                              End If
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
      End If
       strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound, searchvalue
    Next i
End Sub

0
 
bsharathAuthor Commented:
I get run time error. 13
0
 
Hitesh ManglaniCommented:
can you upload the files i have tried this macro it works fine
0
 
bsharathAuthor Commented:
Uploaded

http://www.filepatio.com/3643
http://www.filepatio.com/3644 

On has the macro and other search file which i have in C:\
0
 
Hitesh ManglaniCommented:
Please dont keep the search file in C:\ newfolder and use the following macro
Sub FindFile()
    Dim str1 As String
    str1 = InputBox("SearchValue")
    FindFiles3 "C:\newfolder", "*.*", False, str1
End Sub

Sub FindFiles3(strFolder As String, strFilePattern As String, bFound As Boolean, searchvalue As String)
    Dim strFileName As String
    Dim strFolders() As String
    Dim strFiles() As String
    Dim iFolderCount As Integer
    Dim i As Integer
    Static s2row As Integer
    Dim ws As Workbook
    s2row = 1
    'collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        Else
           
           If InStr(1, strFileName, ".xls", vbTextCompare) > 0 Then

                 Set ws = GetObject(strFolder & "\" & strFileName)
                 For i = 1 To ws.Worksheets.Count
                      For j = 1 To ws.Sheets(i).UsedRange.Rows.Count
                          For k = 1 To ws.Sheets(i).UsedRange.Columns.Count
                            If UCase((ws.Sheets(i).Cells(j, k).Value)) = UCase(searchvalue) Then
                               ws.Sheets(i).Rows(j).Copy Destination:=ActiveWorkbook.Sheets(2).Rows(s2row)
                                  s2row = s2row + 1
                              End If
                         Next
                      Next
                 Next
                 ws.Close savechanges:=False
               Set ws = Nothing
        End If
      End If
       strFileName = Dir$()
    Loop
     
    'look through child folders
    For i = 0 To iFolderCount - 1
        FindFiles3 strFolders(i), strFilePattern, bFound, searchvalue
    Next i
End Sub

0
 
bsharathAuthor Commented:
I think this is working but when i have 5 files in which sharath is there after searching each file it erases the rows and colums and creates new.So i am able to see only the last search
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.