宏循环遍历多个 excel 文件并从每个文件下载数据

Question

这个宏的目标是将来自不同月份的多个 excel 文件的数据合并到一个主 excel 文件中。 我在主 excel 文件（见附图）中为每个月创建了一个选项卡，我希望数据转到并堆叠在一起。

我发现了一些有用的代码，我开始工作了几次，但修改后现在已损坏。 我认为在它可以像我想要的那样工作之前我需要解决的一些问题是：

1. 这段代码是用一个固定的范围构建的，可以复制。 我正在查看的 excel 文件的范围是可变的。

2. 代码在读取Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)的行上不断中断。 这可能是因为我正在测试不同月份文件夹中所有具有相同名称的 excel 文件？

我收到以下错误：“运行时错误 '1004'：Microsoft Excel 无法访问文件 'S:\\Actg\\TESTING\\September\\Loans_20180920.csv'。有几个可能的原因：-文件名或路径不正确不存在。-该文件正被另一个程序使用”。 我检查并删除了我正在测试的所有其他 excel 文件，但 9 月文件夹中的文件除外，但我仍然收到此错误。

3. 有没有办法可以修改此代码，以便我不必每个月复制 12 次？ 我想如果在我输入要下载的月份的地方提示一个文本框会很好。 无论哪种方式......我已经复制了 12 次，所以不会有任何额外的工作。

原始代码参考：Dan Wagner（ 将工作表从多个工作簿复制到当前工作簿中）

这是我正在使用的代码：

Sub Stack_Overflow_Example()

Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long

Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet

FilePath = "S:\Actg\TESTING\September\"
MyFiles = "S:\Actg\TESTING\September\*.csv"
MyFile = Dir(MyFiles)

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With


Set wbMaster = ThisWorkbook
Set wsMaster = wbMaster.Sheets("September")

Do While Len(MyFile) > 0

    If MyFile <> "master.xlsm" Then

        Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
        Set wsTemp = wbTemp.Sheets(1)

        With wsMaster

            erow = .Range("A" & .Rows.Count).End(xlUp).Row
            wsTemp.Range("A2:U88").Copy
            .Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues

        End With

        wbTemp.Close False
        Set wsTemp = Nothing
        Set wbTemp = Nothing
    End If

    MyFile = Dir
Loop

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

如果您有其他问题，请告诉我。

Answer 1

我的情况听起来与您的情况略有不同，因为我从中复制数据的每个工作簿在每个工作簿和主工作簿中都有单独的月份，但这应该会让您走上正确的道路。

请注意，下面的代码假定存在不应复制的标题行。 如果没有，那么您将复制行中的第一行从 2 更改为 1。 如果您需要从多个位置打开文件，您可以在文件打开代码块之前为位置数量添加另一个循环，并为循环的每次迭代更改每个位置的 MyFolder 变量。

Sub RefreshMasterWorkbookData()

'Enable Error Handling
On Error GoTo Oops

'Declare variables and objects
Dim WkBk As Workbook, WkShtMaster As Worksheet, WkShtUser As Worksheet, CopyToRow As Long, PasteAtRow As Long

'Turn off screen updating and calculation to improve process speed and turn off events to keep other code (such as Worksheet_Change) from being triggered
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Open all files in a given directory
Dim MyFolder As String, MyFile As String
MyFolder = "C:\MyFolder" 'OR: "\\NetworkServer\NetworkFolder"
MyFile = Dir(MyFolder & "\*.xlsm") '& "\*.xl*")
Do While MyFile <> ""
    Workbooks.Open FileName:=MyFolder & "\" & MyFile, ReadOnly:=True
    MyFile = Dir
Loop

For Each WkBk In Workbooks 'Loops through each open workbook
    If Not WkBk.Name = ThisWorkbook.Name Then 'If not this master workbook
        For Each WkShtUser In WkBk.Worksheets 'Loops through each worksheet in the current workbook
            Select Case WkShtUser.Name 'Worksheet name for Month
                Case "Jan" 'Jan is the worksheet name for the monthly tab/sheet in the users individual file
                    Set WkShtMaster = M_01 'M_01 is the CodeName of the monthly worksheet in Master file
                Case "Feb"
                    Set WkShtMaster = M_02
                Case "Mar"
                    Set WkShtMaster = M_03
                Case "Apr"
                    Set WkShtMaster = M_04
                Case "May"
                    Set WkShtMaster = M_05
                Case "Jun"
                    Set WkShtMaster = M_06
                Case "Jul"
                    Set WkShtMaster = M_07
                Case "Aug"
                    Set WkShtMaster = M_08
                Case "Sep"
                    Set WkShtMaster = M_09
                Case "Oct"
                    Set WkShtMaster = M_10
                Case "Nov"
                    Set WkShtMaster = M_11
                Case "Dec"
                    Set WkShtMaster = M_12
                Case Else
                    GoTo NextWkSht
            End Select

            PasteAtRow = WkShtMaster.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1 'find first empty row in master sheet for appropriate month

            With WkShtUser 'Clear autofilter, if on, and copy designated columns of data from row 2 through last row
                If .FilterMode = True Then .AutoFilterMode = False
                CopyToRow = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
                If CopyToRow = 1 Then GoTo EmptyWkSht
                .Range("A2", "Z" & CopyToRow).Copy 'Where "Z" is the lst column of data you want to copy
            End With
            WkShtMaster.Range("A" & PasteAtRow).PasteSpecial xlPasteValues 'Paste data to empty rows in master for appropriate month
EmptyWkSht:
            If Not WkShtMaster Is Nothing Then Set WkShtMaster = Nothing
            CopyToRow = 0
            PasteAtRow = 0
NextWkSht:
        Next
        WkBk.Saved = True
        WkBk.Close False
    End If
Next

Oops:
    If Err Then
        Debug.Print Err.Description
        MsgBox "Refresh Error:" & vbNewLine & vbNewLine & Err.Description, vbCritical, "Error..."
    Else
        MsgBox "Refresh Completed Successfully", vbInformation, "Refresh Complete..."
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub