[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 326
  • Last Modified:

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
0
bsharath
Asked:
bsharath
  • 11
  • 8
1 Solution
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
bsharathAuthor Commented:
Get procedure error.
Can you post the full code.
0
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
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
 
hiteshgoldeneyeCommented:
'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

Featured Post

Upgrade your Question Security!

Add Premium security features to your question to ensure its privacy or anonymity. Learn more about your ability to control Question Security today.

  • 11
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now