Код VBA, который проходит по папке и попадает в каждый отдельный файл Excel на один лист и копирует один и тот же диапазон

Question

Я пытаюсь создать работающий код VBA, который проходит по папке и попадает в каждый файл Excel на один лист и копирует тот же диапазон там в другой файл Excel!

У меня был рабочий код (см. Ниже), но почему-то он неправильно отображал вставку копии (например, показывал 12479 как 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, Calculation, EnableEvents, ScreenUpdating, но я бы оставил DisplayAlerts включенным.