使用數組加速我的VBA

Question

我有興趣編程了這個VBA宏，用於從Excel中的一些文本文件中提取和繪製數據。我recentyl試圖在一個稍大的文件，約700行和1太3行進行平均和繪製。這是痛苦的緩慢，我認爲它可以使用數組證明，但我以前在VBA中使用數組的嘗試並不是非常成功，所以我想我會問你們有關如何將下面的代碼從for循環轉換爲陣列增加。

這是我想要轉換的部分。基本上，它可以排列並平均來自特定但未知數量的列的值。

' 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 

在這裏，我參考了整個代碼塊：

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 

非常感謝您對這個問題的任何輸入。 最好的問候， Rikard

Answer 1

我不確定轉換到數組將幫助所有這些。

速贏會關掉計算的全過程：

Application.Calculation = xlCalculationManual

不要忘記再次切換回來後，你就大功告成了。

您也可以關閉屏幕更新：Application.ScreenUpdating = False，但這並不能改善太多情況。

這就是說，VBA中沒有任何內容不能直接在工作表上使用內置的Excel公式完成。這在性能方面可能是最好的。