excel - VBA 代码运行速度非常慢

Question

我有一个可以持续很长时间的循环，虽然“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

Answer 1

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

• 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- 这在大型工作表中可能很慢，因为它必须循环相当多的数据，具体取决于基础范围。

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

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

Answer 2

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

Answer 3

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

代码示例

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

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

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