Как ускорить макрос Excel, который запускается в общем файле? - PullRequest
Новая
       3

Как ускорить макрос Excel, который запускается в общем файле?

1 голос
/ 03 марта 2020

Я собрал код для копирования фрагментов информации из нескольких файлов Excel в один большой мастер-файл. Однако главный файл хранится на общем диске, который почти заполнен. Кроме того, имя файла (и имя папки, в которой можно найти файл) меняется ежемесячно. Я использовал подстановочный знак «*» в конце пути и имени файла. Поскольку есть несколько подпапок, алгоритм может пройти несколько минут, а рабочий лист также зависает на несколько секунд, так что на самом деле я не экономлю время, что было первоначальной целью. Может быть, у вас есть идеи, как немного ускорить процесс? Заранее спасибо!

Вы можете найти код ниже 

Sub OVtablecopy3()

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Copy

    Dim newest As Date
    Dim current As Date
    Dim right_file As String
    Dim rot_cnt As Integer
    rot_cnt = 1

    Dim my_path As String
    Dim file_name As String
    my_path = "\\mypath\which\Icouldnotwritefully\sinceitsconfidential\butyouget\theidea\maybe\*\"
    file_name = Dir("My_monthly changing_filename*.xlsx")

    Do While file_name <> vbNullString
        If rot_cnt = 1 Then
            newest = FileDateTime(file_name)
        End If
        If rot_cnt >= 1 Then
            current = FileDateTime(file_name)
        End If
        If DateSerial(Year(current), Month(current), Day(current)) >= _
                                                                   DateSerial(Year(newest), Month(newest), Day(newest)) Then
            newest = FileDateTime(file_name)
            right_file = file_name
        End If
        file_name = Dir()
        rot_cnt = rot_cnt + 1
    Loop

    Workbooks.Open (right_file)

    ActiveSheet.Paste

    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
...