運行速度很慢的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（）... 先保存你的主人在做出如此大的改變之前，以一個新的名字命名工作簿...