copying workbooks from current folder and also subfolders

Question

This is part of the sub I found to copy all tabs in all workbooks in a directory to my current workbook, but how can I adjust it to scan all subfolders as well? Currently, it only copies from the folder I select and then stops.

Here's the full code with functions: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829

Sub CombineFiles()
  Dim path            As String
  Dim FileName        As String
  Dim LastCell        As Range
  Dim Wkb             As Workbook
  Dim WS              As Worksheet
  Dim ThisWB          As String

  ThisWB = ThisWorkbook.Name
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  path = GetDirectory
  FileName = Dir(path & "\*.xls*", vbNormal)
  Do Until FileName = ""
      If FileName <> ThisWB Then
          Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
          For Each WS In Wkb.Worksheets
              Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
              If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
              Else
                  WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
              End If
          Next WS
          Wkb.Close False
      End If
      FileName = Dir()
  Loop
  Application.EnableEvents = True
  Application.ScreenUpdating = True

  Set Wkb = Nothing
  Set LastCell = Nothing
End Sub

Plenty of similar questions (with answers) here on SO - e.g. http://stackoverflow.com/questions/20687810/vba-macro-that-search-for-file-in-multiple-subfolders/20688126#20688126 — Tim Williams, Jul 17 '14 at 18:51
@TimWilliams In fact I browsed that question prior to posting my own; the relevant information and steps to conversion to my own code was not evident to me. Perhaps that's my own problem. — coburne, Jul 17 '14 at 19:07

score 1 · Answer 1 · edited May 23 '17 at 12:13

Using the code I posted in the linked question (untested)

Sub CombineFiles()
    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As Range
    Dim Wkb             As Workbook
    Dim WS              As Worksheet
    Dim ThisWB          As String
    Dim colFiles As New Collection, fPath

    ThisWB = ThisWorkbook.path & "\" & ThisWorkbook.Name

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = GetDirectory

    GetFiles path, "*.xls*", True, colFiles

    For Each fPath In colFiles

    If fPath <> ThisWB Then
        Set Wkb = Workbooks.Open(FileName:=fPath)

        For Each WS In Wkb.Worksheets
            Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
            If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
            Else
                WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            End If
        Next WS

        Wkb.Close False
      End If

    Next fPath

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing
End Sub

VBA macro that search for file in multiple subfolders

copying workbooks from current folder and also subfolders

1 Answers1