Excel，循环通过XLSM文件并将行复制到另一个工作表 [英] Excel, loop through XLSM files and copy row to another sheet

问题描述

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

我有一个文件夹，大约99个xlsm文件，我正在寻找循环遍历每个文件，并复制我们只是从第14行工作簿并将其粘贴到单独的工作簿中作为总结。
这是我到目前为止唯一的问题是它复制一个空行。当我浏览VB时，我可以看到它不会在打开的xlsm文件上运行宏。任何人都知道一些可以帮助我的代码？

I have a folder with approx 99 xlsm files that I am looking to loop through each file and copy let's just say row 14 from each workbook and paste it into a separate workbook as a summary. Here's what I have so far; the only problem is it copies a blank row. When I stepped through the VB I could see that it doesn't run the macro on the xlsm file it opens. Anyone know some code that will help me here?

 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个源文件和Summary目标文件进行交互。或者，您可以从摘要工作簿中运行所有内容，将 Workbooks.Add 更改为 ActiveWorkbook 。

It really depends where you run this macro. Consider opening another workbook and placing this macro behind a sheet or module, having it interact with all 99 source files and Summary destination file. Alternatively, you can run everything from the Summary workbook, changing Workbooks.Add to the ActiveWorkbook.

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

Below is a slightly revised VBA code. Rather than work with ranges, try copy and paste row by row. Also, no need for invoking the Application.Run macro

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文件并将行复制到另一个工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！