VBA代码运行速度很慢

虽然“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

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

• GetRowRange ： .UsedRange可能会返回比您预期更多的列。 通过在工作表中按Ctrl – End来检查，看看你最终在哪里
• 在你的主例程中的一些东西 – depsheet.UsedRange.Columns(1).Cells可能会导致比预期更多的行
• someRange.Value = "VLOOKUP(...将公式存储为文本，您需要.Formula =而不是.Value （这不会解决您的长运行时间，但肯定会避免另一个bug）
• 在sortSpgs ，将知道或sortSpgs项目添加到控件中。 不知道是否有这些控件背后的事件代码，使用Application.EnableEvents=False禁用事件（理想情况下，在您的.ScreenUpdating = False与一起.ScreenUpdating = False ）
• 另外，在开始处设置Application.Calculation = xlCalculationManual ，在代码末尾设置Application.Calculation = xlCalculationManual
• 你正在执行很多。 .Find – 尤其是。 在sortSpgs – 这在大型表格中可能会很慢，因为它必须循环一些数据，具体取决于基础范围。

一般来说，还有一些“最佳实践备注”：*使用正确的types对variables进行Dim ，对于函数的返回也是一样的*使用With obj可以使代码更清晰。 例如，在setResulcolVars你可以使用With rsheet.UsedRange并在下面的15行左右删除这部分*在小范围的模块中，可以使用一个宽范围的模块将某些variables调暗 – 尤其是， 如果你每次打电话都要交给他们。 这将使您的代码更容易阅读

希望有一点帮助… mvh / P。

Answer 2

我的猜测是Application.Screenupdating是问题。 你在下面设置为false：
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
块。 所以如果不是这样的话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 

另外，也许你可以使用.match而不是.find，这样更快。 与你使用application.match（SearchValue，Array_Name，False）数组'假如完全匹配

同样的事情适用于range.find（），成为application.find（）…在做出如此大的改变之前，首先用新名称保存主工作簿…