Question

我重写它......这样做好一点，但它并不是我想要的......这里有一些示例数据和成品的例子。

示例数据：https://drive.google.com/folderview?id=0B0m5F-NRHk_kTFRyb0JxYmo5Ykk&usp=drive_web

Option Explicit

Sub MergeAllSheetsInAllWorkbooks()
Dim fPATH As String, fNAME As String, LastCol As Long
Dim wb As Workbook, ws As Worksheet, Combined As Worksheet

Application.ScreenUpdating = False                                  'speed up macro execution
Application.DisplayAlerts = False                                   'take default answer for all error alerts

fPATH = ThisWorkbook.Path & "\Files\"                               'path to data files, possibly use ActiveWorkbook

Sheets.Add                                                          'create the new sheet
ActiveSheet.Move                                                    'move to new workbook
Set Combined = ActiveSheet                                          'set anchor to new sheet
Combined.Name = "Combined"                                          'set the name

LastCol = 1                                                         'starting column for new output
fNAME = Dir(fPATH & "*.xls")                                        'get first filename

Do While Len(fNAME) > 0                                             'loop one file at a time
    Set wb = Workbooks.Open(fPATH & fNAME)                          'open the found file
    For Each ws In wb.Worksheets                                    'cycle through all the sheets in the wb
        ws.Range("A1").CurrentRegion.Copy Combined.Cells(1, LastCol)        'copy to COMBINED sheet
        LastCol = Combined.Cells(1, Columns.Count).End(xlToLeft).Column + 1 'set next target column
    Next ws
    wb.Close False                                                  'close the found file

    fNAME = Dir                                                     'get the next filename
Loop
                                                                    'save the results
Combined.Parent.SaveAs "C:\Users\username\Desktop\OCCREPORTS\Target.xlsx", 51
Application.ScreenUpdating = True                                   'update screen all at once 

End Sub

Answer 1

尝试重新排序DoWork子的底部，因为End If应该先到，然后是Next，然后是End With

而不是：

        End With
    End If
Next

做的：

        End If
    Next
End With

将宏应用于一百个工作簿，然后将结果复制到主Excel文件中

1 个答案: