使用数组加速我的VBA
我有兴趣编程这个VBAmacros提取和绘制Excel中的一些文本文件的数据。 我recentyl试了一个稍大的文件，大约700行和1三太行平均和绘制。 这是痛苦的缓慢，我认为它可以使用数组提升，但我以前在VBA中使用数组的尝试不是很成功，所以我想我会问你们一些build议如何将下面的代码从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
我不确定转换到数组将帮助所有这些。
快速取胜将是closures整个过程的计算：
Application.Calculation = xlCalculationManual
一旦完成，不要忘了重新打开它。
您也可以closures屏幕更新： Application.ScreenUpdating = False ，但这并不能正常地改善事情。
这就是说，你的VBA中没有任何东西不能直接使用内置的Excel公式在工作表上完成。 这在性能方面可能是最好的。