Question

我正在尝试制作一个有效的VBA代码，该代码循环遍历一个文件夹，并进入每个excel文件到同一张纸，然后将相同范围复制到另一个excel文件中！

我有一个有效的代码（请参阅下文），但由于某种原因它无法正确显示复制粘贴（例如，显示1,2479为12.479）。我无法解决此问题，因此我寻找了新代码并找到并增强了代码（请参见下文）。

但是，仅9个文件，此代码运行了3分钟以上！最终的文件夹大约有50个文件，因此我有点担心excel无法处理它。

我读到很多关于不使用.select的信息，但我相信我没有这样做。

是否有人有想法来改进我的代码/缩短持续时间？非常感谢您的帮助。似乎很容易做到（它总是从相同的工作表名称和文件夹中每个文件的相同范围进行复制！），但是看来PC的工作非常繁重？

非常感谢您

纯

编辑：我正在使用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

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

对于OptimizeCode集合：我同意以上评论。但是，您可以关闭DisplayPageBreaks，Calculation，EnableEvents，ScreenUpdating，但是我将DisplayAlerts保持打开状态。

VBA代码遍历文件夹，并进入每个不同的excel文件至同一张工作表并复制相同的范围

1 个答案: