VBA code running horrendously slow

Question

I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.

    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

you could also try to write the usedrange in an array, work with it , and write it back if needed.

code example

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

also, maybe you can use .match instead of .find, wich is faster. with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match

the same thing works for range.find() , becoming application.find()... save first your master workbook under a new name before making such a big change...

Answer 2

Difficult to debug without the source files. I see the following potential problems:

• GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
• Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
• someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
• In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
• Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
• You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.

Generally, a few more "best practise remarks": * Dim your variables with the correct types, same for returns of functions * Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines * In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read

Hope that helps a bit... mvh /P.

Answer 3

My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.