宏可循环浏览多个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文件，但“九月”文件夹中的文件除外，但仍然出现此错误。

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

原始代码参考：Dan Wagner（Copying worksheets from multiple workbooks into current workbook）

这是我正在使用的代码：

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