Question

我现在使用此代码的主要问题是处理我正在打开的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

Answer 1

在我的优化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秒钟。因此，我们动态更改可见性。

Answer 2

这真的取决于你运行这个宏的。考虑打开另一个工作簿并将此宏放在工作表或模块后面，使其与所有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

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

2 个答案: