我有一个爱好编程这个VBA宏用于从Excel中的一些文本文件中提取和绘制数据。我在近期的文件上试了一下，大约700行和1行三行进行平均和绘制。这是非常缓慢的，我认为它可以使用数组进行改进，但我之前在VBA中使用数组的尝试并不是非常成功，所以我想我会问你们有关如何将以下代码从for循环变为a的一些建议阵列加法。
这是我要转换的部分。基本上它逐行排列并平均来自特定但未知数量的列的值。
' 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
非常感谢您对此问题的任何意见。 最好的祝福， 里卡德
答案 0 :(得分：1)
我不确定转换为数组会有多大帮助。
快速获胜将关闭整个过程的计算：
Application.Calculation = xlCalculationManual
完成后不要忘记重新打开它。
您也可以关闭屏幕更新：Application.ScreenUpdating = False，但这通常不会改善太多事情。
大家都说过，你的VBA中没有任何内容无法直接在带有内置Excel公式的工作表上完成。这在性能方面可能是最好的。