Question

这是我发现将子目录中所有工作簿中的所有选项卡复制到当前工作簿的子部分，但是如何调整它以扫描所有子文件夹？目前，它只从我选择的文件夹中复制然后停止。

这是包含功能的完整代码：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

Answer 1

使用我在链接问题中发布的代码（未经测试）

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

从当前文件夹和子文件夹复制工作簿

1 个答案: