Excel，通过XLSM文件循环并将行复制到另一个工作表

我现在用这个代码的主要问题是用我打开的xlsm文件处理错误。 我对这些文件上的VB代码没有编辑权限。 有没有办法跳过一个文件，如果VB出错了？

我有一个大约99 xlsm文件的文件夹，我正在通过每个文件循环查看，然后复制每个工作簿中的第14行，并将其作为摘要粘贴到单独的工作簿中。 这是我迄今为止; 唯一的问题是它复制一个空白行。 当我跨过VB，我可以看到，它不会在它打开的xlsm文件上运行macros。 任何人都知道一些代码可以帮助我吗？

Sub MergeAllWorkbooks() Dim SummarySheet As Worksheet Dim FolderPath As String Dim NRow As Long Dim FileName As String Dim WorkBk As Workbook Dim SourceRange As Range Dim DestRange As Range Application.Calculation = xlCalculationAutomatic ' Create a new workbook and set a variable to the first sheet. Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1) ' Modify this folder path to point to the files you want to use. FolderPath = "C:\Users\dredden2\Documents\SHAREPOINT ARCHIVING\PAGESETUP\TEST\" ' NRow keeps track of where to insert new rows in the destination workbook. NRow = 2 ' Call Dir the first time, pointing it to all Excel files in the folder path. FileName = DIR(FolderPath & "*.xlsm") ' Loop until Dir returns an empty string. Do While FileName <> "" ' Open a workbook in the folder Set WorkBk = Workbooks.Open(FolderPath & FileName) WorkBk.Application.EnableEvents = True WorkBk.Application.DisplayAlerts = False WorkBk.Application.Run _ "'" & FileName & "'!auto_open" ' Set the cell in column A to be the file name. SummarySheet.Range("A" & NRow).Value = FileName ' Set the source range to be B14 through BF14. ' Modify this range for your workbooks. ' It can span multiple rows. Set SourceRange = WorkBk.Sheets("Retrospective Results").Range("B14:BF14") ' Set the destination range to start at column B and ' be the same size as the source range. Set DestRange = SummarySheet.Range("B" & NRow) Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _ SourceRange.Columns.Count) ' Copy over the values from the source to the destination. DestRange.Value = SourceRange.Value ' Increase NRow so that we know where to copy data next. NRow = NRow + DestRange.Rows.Count ' Close the source workbook without saving changes. WorkBk.Close savechanges:=False ' Use Dir to get the next file name. FileName = DIR() Loop ' Call AutoFit on the destination sheet so that all ' data is readable. SummarySheet.Columns.AutoFit WorkBk.Application.DisplayAlerts = False SummarySheet.SaveAs FileName:= _ FolderPath & "\SummarySheet\SummarySheet.xlsx" _ , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False End Sub 

Answer 1

这真的取决于你在哪里运行这个macros。 考虑打开另一个工作簿并将该macros放在工作表或模块后面，使其与所有99个源文件和摘要目标文件进行交互。 或者，您可以运行摘要工作簿中的所有内容，将Workbooks.Add更改为ActiveWorkbook 。

下面是一个稍微修改的VBA代码。 不要使用范围，请尝试逐行复制和粘贴。 另外，不需要调用Application.Runmacros

 Sub MergeAllWorkbooks() Dim SummaryWkb As Workbook, SourceWkb As Workbook Dim SummarySheet As Worksheet, SourceWks As Worksheet Dim FolderPath As String Dim FileName As Variant Dim NRow As Long Set SummaryWkb = Workbooks.Add() Set SummarySheet = SummaryWkb.Worksheets(1) FolderPath = "C:\Users\dredden2\Documents\SHAREPOINT ARCHIVING\PAGESETUP\TEST\" FileName = Dir(FolderPath) NRow = 1 While (FileName <> "") If Right(FileName, 4) = "xlsm" Then Set SourceWkb = Workbooks.Open(FolderPath & FileName) Set SourceWks = SourceWkb.Sheets("Retrospective Results") 'FILE NAME COPY SummarySheet.Range("A" & NRow) = FileName 'DATA ROW COPY SourceWks.Range("B14:BF14").Copy SummarySheet.Range("B" & NRow).PasteSpecial xlPasteValues SourceWkb.Close False NRow = NRow + 1 End If FileName = Dir Wend SummarySheet.Columns.AutoFit SummaryWkb.SaveAs FileName:=FolderPath & "\SummarySheet\SummarySheet.xlsx" _ , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False MsgBox "Data successfully extracted!", vbInformation Set SourceWkb = Nothing Set SourceWks = Nothing Set SummarySheet = Nothing Set SummaryWkb = Nothing End Sub 

Answer 2

在我的情况下，优化VBA我们之前使用这个代码：

 Application.DisplayAlerts = False Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.EnableCancelKey = xlDisabled Application.EnableAutoComplete = False Application.EnableEvents = False Application.EnableLivePreview = False Application.EnableMacroAnimations = False sourcesheet.DisplayPageBreaks = False destinationSheet.DisplayPageBreaks = False isHidden = Sheets(destinationSheetName).Visible Sheets(destinationSheetName).Visible = True 

而这段代码之后：

 Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableCancelKey = xlInterrupt Application.EnableAutoComplete = True Application.EnableEvents = True Application.EnableLivePreview = True Application.EnableMacroAnimations = True sourcesheet.DisplayPageBreaks = True destinationSheet.DisplayPageBreaks = True Sheets(destinationSheetName).Visible = isHidden 

最重要的是使用可见的工作表。 在我的情况下，隐形工作表上的代码执行时间是几分钟。 在可见的情况下，需要10秒。 所以，我们dynamic地改变能见度。