VBA to loop through all files in a folder.

[swapnilk]

Hi, i found below code on a website to find specific text in a column and if text matches then copy entire row to new sheet.

Option Explicit

Sub SearchForString()

    Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr as string

    On Error GoTo Err_Execute

    'populate the array for the outer loop
    arr = Array("transfer", "indicate", "water")

    With Worksheets("sheet1")

        'outer loop through the array
        For a = LBound(arr) To UBound(arr)
            'locate first instance
            Set fnd = .Columns("B").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                         MatchCase:=False, SearchFormat:=False)
            If Not fnd Is Nothing Then
               'record address of first find
                addr = fnd.Address
                'seed the cpy range object
                If cpy Is Nothing Then Set cpy = fnd.EntireRow
                Do
                    'build union
                    Set cpy = Union(cpy, fnd.EntireRow)

                    'look for another
                    Set fnd = .Columns("B").FindNext(after:=fnd)

                'keep finding new matches until it loops back to the first
                Loop Until fnd.Address = addr
            End If
        Next a

    End With

    With Worksheets("sheet2")
        'one stop copy & paste operation
        cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
    End With

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
    Debug.Print Now & " " & Err.Number & " - " & Err.Description

End Sub

Can someone please modify the above code to loop through all excel files in a folder and perform the find function on "Sheet1" of all the files and then do the copy function on "Sheet2" of a master file, so basically collecting data from all files in a folder and pasting into one master file. Also, instead of copying entire row can it only copy the adjacent cell value. For e.g say in column B it finds the text "transfer" in cell B20 then instead of copying entire row 20, can it only copy cell C20?

 

[DanteAmor]

Put all the code in one module and run the SearchForString_2macro
When you run the macro it will ask you to select the folder where the excel files are.

Sub SearchForString_2()
  Dim wrd As Variant, arr As Variant
  Dim fnd As Range, cpy As Range, rng As Range
  Dim myPath As String, addr As String, sFile As String, sheetName As String
  Dim wb2 As Workbook
  Dim shd As Worksheet
  
  Application.ScreenUpdating = False
  
  arr = Array("transfer", "indicate", "water")    'populate the array for the outer loop
  sheetName = "Sheet1"                            'Source sheet
  Set shd = Sheets("Sheet2")                      'destination sheet
  
  With Application.FileDialog(msoFileDialogFolderPicker)    'To select the folder
    .Title = "Select Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub
    myPath = .SelectedItems(1)
  End With
  sFile = Dir(myPath & "\" & "*.xls*")
  
  Do While sFile <> ""
    If HasSheet(myPath, sFile, sheetName) Then                  'validates that sheet1 exists
      Set wb2 = Workbooks.Open(myPath & "\" & sFile)
      Set cpy = Nothing
      Set rng = wb2.Sheets(sheetName).Range("B:B")              'Set column B to search
        
      For Each wrd In arr                                       'loop each word in the array
        Set fnd = rng.Find(wrd, , xlValues, xlPart, , , False)  'locate first instance
        If Not fnd Is Nothing Then
          addr = fnd.Address                                    'record address of first find
          If cpy Is Nothing Then Set cpy = fnd.Offset(, 1)      'seed the cpy range object
          Do
            Set cpy = Union(cpy, fnd.Offset(, 1))               'build union
            Set fnd = rng.FindNext(after:=fnd)                  'look for another
          Loop While Not fnd Is Nothing And fnd.Address <> addr
        End If
      Next
      If Not cpy Is Nothing Then cpy.Copy shd.Range("A" & Rows.Count).End(3)(2)
      wb2.Close False
    End If
    sFile = Dir()
  Loop
  Application.ScreenUpdating = True
      
  MsgBox "All matching data has been copied."
End Sub

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "\[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function