Question

我有一个可以持续很长时间的循环，虽然“Enheder”工作表只有10行，而数据集im loadin可能有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（这不会解决您的长时间运行时但肯定会避免另一个错误）
在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
块。因此，如果不是这种情况，则不会禁用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）'如果完全匹配则为false

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

VBA代码运行速度极慢

3 个答案: