运行速度很慢的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键检查 - 结束工作表，看看你在哪里结束
• 有些事情在你的主程序 - depsheet.UsedRange.Columns(1).Cells可能只是导致更多的行比预期
• someRange.Value = "VLOOKUP(...将存储公式为文本。您需要.Formula =而不是.Value（这不会解决您的长运行时间，但肯定会避免另一个bug）
• 在sortSpgs中，您将已知或未知项添加到控件中。不知道如果有这些控件之后的任何事件代码，以Application.EnableEvents=False（一起最好在你的主子的开头与.ScreenUpdating = False）禁用事件
• 此外，设置Application.Calculation = xlCalculationManual在开始和Application.Calculation = xlCalculationAutomatic你的代码的最后
• 您正在执行很多.Find - 尤其是。在sortSpgs中 - 这在大型表格中可能会很慢，因为它必须循环一些数据，具体取决于基础范围。

一般情况下，多了一些“最佳做法的言论”： * Dim你用正确类型的变量，对于相同的功能 回报*使用With obj使代码更干净。例如。在setResulcolVars中，您可以使用With rsheet.UsedRange，并在以下15行左右删除此部分。 *在小范围模块中，可以使用模块范围较宽的某个变量进行调光 - 尤其是，如果你每次打电话都要交给他们。这将使你的代码更容易阅读

希望能帮助一下... mvh/P.

Answer 2

我的猜测是Application.Screenupdating是问题所在。你在内部设置为false：
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block。所以如果情况并非如此，screenupdateing不会被禁用。你应该将它移动到函数的开头。

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 

也，也许你可以用它代替.find .match，至极更快。 使用数组使用application.match（SearchValue，ARRAY_NAME，假）“假，如果完全匹配

同样的事情适用于range.find（），成为application.find（）... 先保存你的主人在做出如此大的改变之前，以一个新的名字命名工作簿...