我现在用此代码遇到的主要问题是处理我打开的xlsm文件的错误。我没有这些文件上的VB代码的编辑权限。如果vb错误，是否可以跳过文件？
我有一个包含约99个xlsm文件的文件夹，我希望遍历每个文件并进行复制，让我们说每个工作簿的第14行，然后将其粘贴到单独的工作簿中作为摘要。这是我到目前为止所拥有的；唯一的问题是它复制了空白行。当我逐步执行VB时，我看到它没有在打开的xlsm文件上运行宏。有人知道一些对我有帮助的代码吗？
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
这实际上取决于您在哪里运行此宏。考虑打开另一个工作簿，并将此宏放置在工作表或模块的后面，使其与所有99个源文件和“摘要”目标文件交互。或者，您可以运行“摘要”工作簿中的所有内容，并将其更改Workbooks.Add为ActiveWorkbook。
下面是经过稍微修改的VBA代码。与其使用范围，不如尝试逐行复制和粘贴。另外，无需调用Application.Run宏
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
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句