Speed up my VBA using arrays

Question

I have hobby programmed this a VBA macro for extracting and plotting data from some text files in Excel. I recentyl tried it on a slightly bigger file, about 700 lines and 1 too three rows to be averaged and plotted. It is painfully slow and i think it can be inproved using arrays but my previous atempt at usings arrays in VBA was not very successfull so i thought i would ask you guys for some advice on how to turn the following code from a for loop into a array addition.

Here is the part I want to convert. Basically it goes line to line and averages the values from a specific but unknown number of columns.

' Add all Stribeckcurves
        l = 8
        For k = skriv + 4 To skriv + 45
            meanSpeed = 0
            meanTraction = 0
            For m = 1 To NumberOfColumns
                meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
                meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
            Next m
            shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
            shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
            l = l + 1
        Next k

Here i the whole code block for reference:

Sub loppthroughfolder()
Dim mainwb As Workbook, Datwb As Workbook, filename As String, arrFileName() As String, shtraw As Worksheet, shtmean As Worksheet, lastrow As Long, lastColumn As Long, j As Integer, profile As String, duplicateArray As Variant, meanSpeed As Double, meanTraction As Double

Set mainwb = ActiveWorkbook
Worksheets("rawData").Cells.Clear
Worksheets("mean").Cells.Clear
Charts("plot").Activate
For Each s In ActiveChart.SeriesCollection
      s.Delete
Next s

Set shtraw = ThisWorkbook.Worksheets("rawData")
Set shtmean = ThisWorkbook.Worksheets("mean")
Set shtcon = ThisWorkbook.Worksheets("configure")
Set shtplot = ThisWorkbook.Charts("plot")

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
    .Show
    .AllowMultiSelect = False
    If .SelectedItems.Count = 0 Then
        MsgBox "You did not select a folder"
        Exit Sub
    End If
    MyFolder = .SelectedItems(1)
End With

Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
Set folderObj = fileSystemObject.getfolder(MyFolder)

shtraw.Select
For Each fileObj In folderObj.Files 'loop through files

    If (fileSystemObject.GetExtensionName(fileObj.Path) = "txt") Then

        If Not fileObj.Attributes And 2 Then
            arrFileName = Split(fileObj.Path, "\")
            Path = "TEXT:" & fileObj.Path
            filename = arrFileName(UBound(arrFileName))

            'Get the filename without the.mtmd
            CustName = Mid(filename, 1, InStr(filename, ".") - 1)
            range("$A$1").value = CustName

            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileObj.Path, Destination:=range("$A$2"))
                .name = filename
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 437
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With
        End If 'end if hidden if statement
    End If 'end of txt
Next fileObj 'close loop

range("$A$1:$B$1").Delete shift:=xlToLeft

lastrow = shtraw.UsedRange.Rows.Count
lastColumn = shtraw.UsedRange.Columns.Count

' Some formating before the sorting
For i = 1 To lastColumn Step 2
    shtraw.Cells(9, i + 1) = shtraw.Cells(9, i)
Next i

' Sort the result after the second line in the comments
shtraw.Sort.SortFields.Clear
shtraw.Sort.SortFields.Add Key:=range(shtraw.Cells(9, 1), shtraw.Cells(9, lastColumn)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With shtraw.Sort
    .SetRange range(Cells(1, 1), Cells(lastrow, lastColumn))
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlLeftToRight
    .Apply
End With

duplicateArray = findCopies(shtraw, lastColumn)


j = 1
For Each i In duplicateArray
    ' Find out how many columns there are for this FM
    If j = UBound(duplicateArray) + 1 Then
        NumberOfColumns = (lastColumn + 1 - duplicateArray(j - 1)) / 2
    Else
        NumberOfColumns = (duplicateArray(j) - duplicateArray(j - 1)) / 2
    End If

    ' Find out how many rows of comments there are
    commentsEnd = findFunc("rawData", i, "Number of steps in profile:", 0, "top") - 1

    ' Add the test name and sample name
    shtmean.Cells(1, 3 * j - 2) = shtraw.Cells(1, i)
    shtmean.Cells(2, 3 * j - 2) = shtraw.Cells(6, i + 1)

    ' Add all row of comments
    l = 3
    For k = 8 To commentsEnd
        shtmean.Cells(l, 3 * j - 2) = shtraw.Cells(k, i)
        l = l + 1
    Next k

    ' Extract the profile name
    profile = Mid(shtraw.Cells(4, i + 1).value, InStrRev(shtraw.Cells(4, i + 1).value, "Profiles\") + 9, InStrRev(shtraw.Cells(4, i + 1).value, "."))
    shtmean.Cells(5, 3 * j - 2) = Mid(profile, 1, InStr(profile, ".") - 1)

    ' Add the time and date the test started
    shtmean.Cells(6, 3 * j - 2) = Mid(shtraw.Cells(12, i).value, InStrRev(shtraw.Cells(12, i).value, "at") + 3)

    ' Find the last Stribeck curve
    skriv = findFunc("rawData", i + 1, shtcon.Cells(9, 2), lastrow, "bottom")

    ' Time step or Stribeck curve
    If shtcon.Cells(9, 2) = "STRIBECK" Then

        ' Add all Stribeckcurves
        l = 8
        For k = skriv + 4 To skriv + 45
            meanSpeed = 0
            meanTraction = 0
            For m = 1 To NumberOfColumns
                meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
                meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
            Next m
            shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
            shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
            l = l + 1
        Next k

    ElseIf shtcon.Cells(9, 2) = "BOD_TIMED" Then

        l = 8
        For k = skriv + 4 To skriv + 723
            meanSpeed = 0
            meanTraction = 0
            For m = 1 To NumberOfColumns
                meanSpeed = meanSpeed + shtraw.Cells(k, i + 2 * m - 2)
                meanTraction = meanTraction + shtraw.Cells(k, i + 2 * m - 1)
            Next m
            shtmean.Cells(l, 3 * j - 2) = meanSpeed / NumberOfColumns
            shtmean.Cells(l, 3 * j - 1) = meanTraction / NumberOfColumns
            l = l + 1
        Next k

    Else
        MsgBox "Skriv STRIBECK eller BOD_TIMED"
        Exit Sub
    End If

    ' Plot it
    With Charts("plot")
        .ChartType = xlXYScatterSmooth
        .SeriesCollection.NewSeries
        .SeriesCollection(j).name = shtmean.Cells(4, 3 * j - 2)
        .SeriesCollection(j).XValues = range(shtmean.Cells(8, 3 * j - 2), shtmean.Cells(l - 1, 3 * j - 2))
        .SeriesCollection(j).Values = range(shtmean.Cells(8, 3 * j - 1), shtmean.Cells(l - 1, 3 * j - 1))
        .SeriesCollection(j).Format.Fill.Visible = msoFalse
        .SeriesCollection(j).Format.Line.Visible = msoFalse
    End With
    j = j + 1

Next i

' Edit plot

    If shtcon.Cells(9, 2) = "STRIBECK" Then

        With Charts("plot")
            'X axis name
            .Axes(xlCategory, xlPrimary).HasTitle = True
            .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Speed (mm/s)"
            'y-axis name
            .Axes(xlValue, xlPrimary).HasTitle = True
            .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
            'Scale Axis
            .Axes(xlCategory).ScaleType = xlLogarithmic
            .Axes(xlCategory).MinimumScale = 4.5
            .Axes(xlCategory).MaximumScale = 3500
        End With

    ElseIf shtcon.Cells(9, 2) = "BOD_TIMED" Then
        With Charts("plot")
            'X axis name
            .Axes(xlCategory, xlPrimary).HasTitle = True
            .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Time (s)"
            'y-axis name
            .Axes(xlValue, xlPrimary).HasTitle = True
            .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
            'Scale Axis
            .Axes(xlCategory).ScaleType = xlScaleLinear
            .Axes(xlCategory).MinimumScale = 10
            .Axes(xlCategory).MaximumScale = 7200
        End With
    End If

With Charts("plot")
    'X axis name
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Speed (mm/s)"
    'y-axis name
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Friction coefficient"
    'Scale Axis
    .Axes(xlCategory).ScaleType = xlLogarithmic
    .Axes(xlCategory).MinimumScale = 4.5
    .Axes(xlCategory).MaximumScale = 3500
End With

ActiveWorkbook.Save

End Sub

Thank you very much for any input on this problem. Best regards, Rikard

Answer 1

I'm not sure that converting to arrays will help all that much.

A quick win will be to switch off calculation for the entire process:

Application.Calculation = xlCalculationManual

Don't forget to switch it back on again once you're done.

You can also switch off screen updating: Application.ScreenUpdating = False, but that doesn't improve things too much normally.

That all said, there's nothing in your VBA that can't be done directly on a worksheet with the built-in Excel formulas. That's probably best in terms of performance.