VBA 代码运行速度非常慢

VBA code running horrendously slow

提问by Jakob

I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.

我有一个可以持续很长时间的循环，虽然“Enheder”工作表只有大约 10 行，而我加载的数据集可能有 300 行，但我尝试导入时需要很长时间。

    Public Function ImportData()
    Dim resultWorkbook As Workbook
    Dim curWorkbook As Workbook
    Dim importsheet As Worksheet
    Dim debugsheet As Worksheet
    Dim spgsheet As Worksheet
    Dim totalposts As Integer

    Dim year As String
    Dim month As String
    Dim week As String
    Dim Hospital As String
    Dim varType As String
    Dim numrows As Integer
    Dim Rng As Range
    Dim colavg As String
    Dim timer As String
    Dim varKey As String


    year = ImportWindow.ddYear.value
    month = ImportWindow.ddMonth.value
    week = "1"
    varType = ImportWindow.ddType.value
    Hospital = ImportWindow.txtHospital.value


    Set debugsheet = ActiveWorkbook.Sheets("Data")
    Set spgsheet = ActiveWorkbook.Sheets("Sp?rgsm?l")
    Set depsheet = ActiveWorkbook.Sheets("Enheder")
    Set resultWorkbook = OpenWorkbook()
    setResultColVars debugsheet

    'set sheets
    Set importsheet = resultWorkbook.Sheets("Dataset")
    numrows = debugsheet.UsedRange.Rows.Count


    'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
    If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
        Dim DepColumn
        Dim aCell
        DepColumn = importsheet.UsedRange.Find("afdeling").column

        'sort importsheet to allow meaningfull row calculations
        Set aCell = importsheet.UsedRange.Columns(DepColumn)
        importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes

        Dim tempRange As Range
        Dim SecColumn
        Dim secRange As Range
        'find row ranges for departments
        Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**


 For Each c In depsheet.UsedRange.Columns(1).Cells
    splStr = Split(c.value, "_")
    If UBound(splStr) = -1 Then
    ElseIf UBound(splStr) = 0 Then
    totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
    ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
    totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
    End If
    Next
    Application.ScreenUpdating = True

    ' go through columns to get total scores
    totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)

    resultWorkbook.Close Saved = True

    ResultsWindow.lblPoster.Caption = totalposts
    ImportWindow.Hide
    ResultsWindow.Show
Else
    MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datas?t"
End If

End Function

Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function

'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
    Dim tempi
    tempi = numrows + totalposts + 1

    Set Rng = varRange.Columns(i)
    With Application.WorksheetFunction
        'make sure that the values can calculate
        If (.CountIf(Rng, "<3") > 0) Then
            colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
            insert = True
        Else
            insert = False
        End If
    End With

    'key is the variable
    varKey = importsheet.Cells(1, i)
    'only add datarow if the data matches a spg, and the datarow is not actually a department
    If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
    resultsheet.Cells(tempi, WyearCol).value = year
    resultsheet.Cells(tempi, WmonthCol).value = month
    resultsheet.Cells(tempi, WweekCol).value = "1"
    resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
    resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
    resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
    resultsheet.Cells(tempi, WdepnrCol).value = dep
    resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
    resultsheet.Cells(tempi, WjtypeCol).value = varType
    resultsheet.Cells(tempi, WspgCol).value = varKey
    resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Sp?rgsm?l!$D:$I,6,0)"
    resultsheet.Cells(tempi, WtestCol).value = ""
    resultsheet.Cells(tempi, Wsv1Col).value = colavg
    resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
    resultsheet.Cells(tempi, Wsv3Col).value = ""
    resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Sp?rgsm?l!$D:$I,4,0)"

    totalposts = totalposts + 1
    End If
Next
End If
IterateColumns = totalposts
End Function

'Function that gets the workbook for import
Function OpenWorkbook()
    Dim pathString As String
    Dim resultWorkbook As Workbook

    pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")

    ' check if it's already opened
    For Each wb In Workbooks
        If InStr(pathString, wb.Name) > 0 Then
            Set resultWorkbook = wb
            Exit For
        End If
    Next wb

    If Not found Then
        Set resultWorkbook = Workbooks.Open(pathString)
    End If

    Set OpenWorkbook = resultWorkbook
End Function


'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("?r").column
WmonthCol = rsheet.UsedRange.Find("M?ned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("sp?rgsm?l").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function

Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
    If (sortspg) Then
        ResultsWindow.lstGenkendt.AddItem key
    End If
    sortSpgs = True
Else
    If (sortspg) Then
        ResultsWindow.lstUgenkendt.AddItem key
    End If
    sortSpgs = False
End If
End Function

Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function

回答by Peter Albert

Difficult to debug without the source files. I see the following potential problems:

没有源文件很难调试。我看到以下潜在问题：

• GetRowRange: .UsedRangemight return more columns than you expect. Check by pressing Ctrl-Endin the worksheet and see where you end up
• Some thing in your main routine - depsheet.UsedRange.Columns(1).Cellsmight just result in much more rows than expected
• someRange.Value = "VLOOKUP(...will store the formula as text. You need .Formula =instead of .Value(this will not solve your long runtime but certainly avoid another bug)
• In sortSpgsyou add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False(ideally in the beginning of your main sub together with the .ScreenUpdating = False)
• Also, set Application.Calculation = xlCalculationManualat the beginning and Application.Calculation = xlCalculationAutomaticat the end of your code
• You're performing a lot of .Find- esp. in sortSpgs- this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.

• GetRowRange:.UsedRange可能会返回比您预期更多的列。在工作表中按Ctrl-End进行检查，然后查看最终位置
• 您的主要例程中的某些事情 -depsheet.UsedRange.Columns(1).Cells可能只会导致比预期多得多的行
• someRange.Value = "VLOOKUP(...将公式存储为文本。你需要.Formula =而不是.Value（这不会解决你的长时间运行，但肯定会避免另一个错误）
• 在sortSpgs您将已知或未知项目添加到控件中。不知道这些控件背后是否有任何事件代码，禁用事件Application.EnableEvents=False（最好在主子的开头和.ScreenUpdating = False）
• 另外，Application.Calculation = xlCalculationManual在代码的开头和Application.Calculation = xlCalculationAutomatic结尾设置
• 你正在表演很多.Find- 尤其是。in sortSpgs- 这在大表中可能会很慢，因为它必须循环相当多的数据，具体取决于基础范围。

Generally, a few more "best practise remarks": * Dimyour variables with the correct types, same for returns of functions * Use With objto make the code cleaner. E.g. in setResulcolVarsyou could use With rsheet.UsedRangeand remove this part in the following 15 or so lines * In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read

通常，还有一些“最佳实践说明”： *Dim具有正确类型的变量，对于函数的返回也是如此 *With obj用于使代码更清晰。例如，setResulcolVars您可以With rsheet.UsedRange在以下 15 行左右中使用和删除这部分 * 在小范围的模块中，可以将某些具有模块范围的变量变暗 - 尤其是。如果你每次打电话都交出来。这将使您的代码更易于阅读

Hope that helps a bit... mvh /P.

希望有所帮助... mvh / P。

回答by alonisser

My guess is that Application.Screenupdatingis the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.

我的猜测是这Application.Screenupdating就是问题所在。您在:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
块内设置为 false 。因此，如果情况并非如此，则不会禁用屏幕更新。你应该把它移到函数的开头。

回答by Patrick Lepelletier

you could also try to write the usedrange in an array, work with it , and write it back if needed.

您也可以尝试将 usedrange 写入数组，使用它，并在需要时将其写回。

code example

代码示例

dim MyArr() as Variant

redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value

'calculating with Myarray instead of ranges (faster)

usedrange.value=myarray 'writes changes back to the sheet/range

also, maybe you can use .match instead of .find, wich is faster. with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match

另外，也许您可​​以使用 .match 而不是 .find，这会更快。对于数组，您使用 application.match( SearchValue, Array_Name, False) 'false 如果完全匹配

the same thing works for range.find() , becoming application.find()... save first your master workbook under a new name before making such a big change...

同样的事情适用于 range.find() ，成为 application.find() ......在进行如此大的更改之前，先以新名称保存您的主工作簿......