Question

问题：

从7月到现在，它从非常快的速度减慢到了不可思议的速度（5秒或更短到30分钟+）。

我将整个代码库从Juni复制到一个旧文件中，这不再慢了。

代码更改主要是肤浅的。我第一次注意到增长放缓是在7月。现在太慢了，它停止工作了。将代码粘贴到旧文件后，速度变慢了，但是我想知道是什么原因造成的，以及将来如何防止这种情况。

功能说明

这是一种日历，其中包含多台计算机，历时一周，并将其活动分类到各个类别中以生成报告。

首先，它从7天（每天计算机创建一个报告）开始加载名称，描述和2个时间戳（用于开始和结束）。我构建了一个小的图形界面来自动执行用户的大部分输入。这些数据条目保存在行中，需要清除以仅具有有效条目。之后，它将从另外2个来源加载数据以完成数据集。这里将有很多重叠之处，自动执行“修剪”算法是此File的重点。

此后，用户将有一个数据透视表和多个表以使漏洞和错误（在日历内）可见并准备报告。

正常情况下，每周大约有450条条目。许多宏会多次执行。
执行此代码的笔记本电脑应处理负载：
I7 4600U + 8GB内存
我从中获取数据的文件位于网络驱动器上。

我尝试过的事情：

我研究了加快代码并重新编写大部分mistakes的方法。
我为查询和连接添加了垃圾回收，并删除了旧的命名范围。
编写函数以在执行时禁用不必要的工作
扫描代码是否变慢

我观察到的事情

新文件的RAM使用量为280 MB，并且在执行宏时会增加到900MB。
带有新代码的旧文件的RAM使用量为90 MB，执行时最大为100MB。
我怀疑它由于缓慢上升到极端RAM使用率而陷入了无休止的复制数据循环中。但是为什么在新文件中会没事呢？

代码示例：

我发现这个特定部分有时最多需要10分钟：此代码部分对于限制我的宏必须执行的次数至关重要。

 '##################################Custom sort 
With Sheets("Knopf_Cronjob").sort
    With .SortFields
        .clear 'Sorts on three Values, Machine Name, Start time and End time
        .Add Key:=Range("C2:C" & lgletzte), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("E2:E" & lgletzte), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("F2:F" & lgletzte), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A1:R" & lgletzte)
    .Header = xlYes
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

此部分有时大约需要5-10分钟：

 For Row = lgletzte To 2 Step -1
        'iterates the whole sheet to look for Monday and saturday,
        ' to cut the Time around 6 a clock and split into two Entrys
        weekday1 = Weekday(.Cells(Row, 5), vbMonday)

        If weekday1 = 1 Or weekday1 = 6 Then
            'Column 5 is the Start time, Column 6 the End Time
            'this looks for Start times before 6 a clock and End Times after 6  a clock
            If (.Cells(Row, 5) - Int(Sheets("Knopf_Cronjob").Cells(Row, 5))) < 0.25 And _
                                                                             (.Cells(Row, 6) - Int(.Cells(Row, 6))) > 0.25 Then
                .Rows(Row).EntireRow.Copy Destination:=Worksheets("Knopf_Cronjob").Rows(lgletzte + 1) 'Copies to new Row
                .Cells(lgletzte + 1, 5).Value2 = 0.25 + Int(.Cells(Row, 5))
                'sets the Split time to 6 a clock
                .Cells(Row, 6).Value2 = 0.25 + Int(.Cells(Row, 6))
                lgletzte = lgletzte + 1          'adds 1 to the last row
            End If
        End If
    Next Row
End With

我认为这些代码段不是特别的问题。

这是插入一天数据的宏：
通常，此过程大约需要一秒钟，但是最近需要2-5分钟。

Sheets("last_day_status").Activate
With ActiveSheet.Cells 'Clears the place holder sheet for the New Data
    .clear
    .ClearContents
End With


'################################## Reading last_day_status
'Change Path here
'***********************************************************************************************************************************
On Error GoTo 404 'routine to catch if the File isn´t found
Sheets("last_day_status").Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "path" & d & "_last_day_status.csv", _
        Destination:=Range("$A$1"))
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .refresh BackgroundQuery:=False
    End With
'***********************************************************************************************************************************


Dim b As Long
Dim c As Date

b = Sheets("last_day_status").Range("A65536").End(xlUp).Row 'b is the last row that contains Data

c = d - 1 'c is one day before the given Date
'In Format "M/T/JJJJ"
Dim x1 As Integer
Dim x2 As Integer
Dim x3 As Integer
Dim Datum As String
Dim tag As String
Dim monat As String
Dim jahr As String

'############################
'day
x1 = InStr(1, c, ".")
tag = Mid(c, 1, x1 - 1)

'Month
x2 = InStr(x1 + 1, c, ".")
monat = Mid(c, x1 + 1, x2 - x1 - 1)

'Year
x3 = Len(c) + 2
jahr = Mid(c, x2 + 1, x3 - x2)

If Len(tag) > 1 Then
x1 = InStr(1, tag, "0")
tag = Mid(tag, x1 + 1, Len(tag))
End If

If Len(monat) > 1 Then
x2 = InStr(1, monat, "0")
monat = Mid(monat, x2 + 1, Len(monat))
End If

Datum = monat & "/" & tag & "/" & jahr


'Filters out only maschines that are Activity Tracked
'***********************************************************************************************************************************
xxx
'*************************************************************************************************************************************

'################################## Copies Data to Mainsheet
a = Sheets("last_day_status").Range("A65536").End(xlUp).Row 'b is the last row that contains Data


Sheets("last_day_status").Range(Cells(65536, 3).End(xlUp), Cells(2, 7)).SpecialCells(xlCellTypeVisible).Copy _
    Sheets("Knopf_Cronjob").Range("C" & a) 'Copies Data
Sheets("Knopf_Cronjob").Activate

Dim lgletzte As Long
Dim lgcount As Long

a = 0
With Sheets("Knopf_Cronjob")
lgletzte = .Range("C65536").End(xlUp).Row
    .Range("E2:F" & lgletzte).NumberFormat = "dd.mm.yyyy hh:mm" 'formates the Time Columns

For lgcount = lgletzte To 2 Step -1

'################################## Deletes Times before the given Week
    If .Cells(lgcount, 6) < Int(.Cells(1, 12)) Then 'end before Monday = Delete
        .Rows(lgcount).Delete
    End If
    If .Cells(lgcount, 5) < Int(.Cells(1, 12)) Then '
        If .Cells(lgcount, 6) > Int(.Cells(1, 12)) Then 'Cuts of start to Start of the week
            .Cells(lgcount, 5).Value2 = Int(.Cells(1, 12))
    Else
            .Rows(lgcount).Delete
            lgcount = lgcount - 1
        End If

    End If
'''''''''''''''''''''''''''''''''''

'##################################Deletes Times after the given Week
    If .Cells(lgcount, 6) > Int(.Cells(1, 13)) Then
        If .Cells(lgcount, 5) < Int(.Cells(1, 13)) Then
            .Cells(lgcount, 6) = Int(.Cells(1, 13))
        Else
            .Rows(lgcount).Delete
            lgcount = lgcount - 1
        End If
    End If


'################# Sorts the activity Name into Groups
    Dim typename As String
    typename = .Cells(lgcount, 4).Value 'column 4 is the Activity Column
    Select Case typename
    Case "Pretest"
        .Cells(lgcount, 7).Value = "Test" ' Column 7 is reserved for comments
        .Cells(lgcount, 4).Value = "Test"
    Case "Test"
        .Cells(lgcount, 4).Value = "TEST"
    Case "Wait"
        .Cells(lgcount, 4).Value = "WAIT"
    End Select
Next lgcount
'''''''''''''''''''''''''''''''''''


'Deletes times that are close to Midnight
lgletzte = .Range("C65536").End(xlUp).Row
For lgcount = lgletzte To 2 Step -1
    If .Cells(lgcount, 5) - Int(.Cells(lgcount, 5)) <= 0.0001 Then
        .Cells(lgcount, 5).Value2 = Int(.Cells(lgcount, 5))
    End If
    If .Cells(lgcount, 6) - Int(.Cells(lgcount, 6)) <= 0.0001 Then
        .Cells(lgcount, 6).Value2 = Int(.Cells(lgcount, 6)) - 0.0000116
    End If

Next lgcount
End With

问题还在于，这种减速会影响每个宏。

Excel VBA宏神秘减速

问题：

功能说明

我尝试过的事情：

我观察到的事情

代码示例：

0 个答案: