循环遍历文件夹中的每个Excel文件，到相同的工作表中复制相同的范围

Question

我试图循环遍历文件夹中的每个Excel文件，将相同的工作表复制到另一个Excel文件中。

我有一个代码，但它没有正确地显示复制粘贴(例如，显示1,2479为12.479)。我寻找了一个新的代码，并找到并增强了一个。

但是，仅对9个文件，此代码运行超过3分钟。该文件夹将有大约50个文件，所以我有点担心excel将无法处理它。

我读了很多关于不使用.Select的文章，但我相信我不会这么做。

我正在使用Excel 2010

原始代码

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String

'Setting the right folder where the cartographies are
Filepath = "C:\Users\xxx\OneDrive - xxx\Testexcel\"
MyFile = Dir(Filepath)
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
'Application.DecimalSeparator = ","
'Application.ThousandsSeparator = "."
'Application.UseSystemSeparators = False

Do While Len(MyFile) > 0
    'If MyFile = "zmaster.xlsm" Then
    'Exit Sub
    'End If
    
    'Open all the workbook
    Workbooks.Open (Filepath & MyFile)
    'Activate the right worksheet in the cartography file
    Worksheets("xxxxxx").Activate
    'Highlight the range of cells we want to copy
    Range("E2:H2").Copy
    ActiveWorkbook.Close
    
    'Add the copied cells to our sheet in the master file
    Worksheets("xxxxxx").Activate
    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    ActiveSheet.Range(Cells(erow, 1), Cells(erow, 4)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlPasteSpecialOperationNone
    
    MyFile = Dir
Loop

'Application.UseSystemSeparators = True

End Sub

当前代码

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem As Variant
Dim FileDlg As FileDialog
Dim FileName, Standalone, Range2copy As String
Dim Cartography As Workbook
Dim TargetSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
'Optimize Code
Call OptimizeCode_Begin
'Give the name of the sheet of cartography where data should be gathered
Standalone = "xxxxxxxx"
'Say the range of the data to be copied from the sheet
Range2copy = "E2:H2"

Set Workbook = ThisWorkbook
Set TargetSheet = Workbook.Sheets("Consolidated Cartography")

'Ask in pop-up where the folder is located with the excel files to update
Set FileDlg = Application.FileDialog(msoFileDialogFolderPicker)

With FileDlg
    If .Show = -1 Then
        xSelItem = .SelectedItems.Item(1)
        FileName = Dir(xSelItem & "\*.xls*", vbNormal)
        If FileName = "" Then Exit Sub
        Do Until FileName = ""
        'Open the first file in the folder
            Set Cartography = Workbooks.Open(xSelItem & "\" & FileName)
            'Open the right active sheet with data to be copied and put range into xRg
            Set xRg = Cartography.Worksheets(Standalone).Range(Range2copy)
            'Copy  xRg to the TargetSheet at location starting at A250, go up to last row with data then one down
            xRg.Copy TargetSheet.Range("A250").End(xlUp).Offset(1, 0)
            FileName = Dir()
            Cartography.Close
        Loop
    End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
'Optimize Code
Call OptimizeCode_End
End Sub

我在网上发现了这个。它确实试图通过禁用某些事件和触发器来使代码更快。

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

End Sub

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True

End Sub

Answer 1

通过计数目标行，而不是在每个循环中找到目标行，可以获得一些速度改进。因此，在初始化阶段(退出循环)：

Dim iTrgRow As Long
iTrgRow = TargetSheet.Range("A250").End(xlUp).Offset(1, 0).Row

然后在循环中：

Cartography.Worksheets(Standalone).Range(Range2copy).Copy Destination:=TargetSheet.Cells(iTrgRow, 1)
iTrgRow = iTrgRow + 1

这将将复制缓冲区粘贴到A列，iTrgRow。只要您复制一行数据，就可以了。

对于OptimizeCode收藏:我同意上面的评论。然而，您可以关闭DisplayPageBreaks，计算，EnableEvents，ScreenUpdating，但我会让DisplayAlerts继续运行。