如何在 VBA 中创建 n 个数组
Posted
技术标签:
【中文标题】如何在 VBA 中创建 n 个数组【英文标题】:How to create n number of arrays in VBA 【发布时间】:2022-01-11 04:31:14 【问题描述】:我有以下代码可以完美运行并完成我需要的技巧。
但是我希望这段代码运行 n 次并创建 n 个数组。
我的数据集是:
我的代码是:
Option Explicit
Private Sub Test()
Const startRow As Long = 2
Const valueCol As Long = 2
Const outputCol As Long = 4
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, valueCol).End(xlUp).Row
Dim inputArr As Variant
inputArr = ws.Range(ws.Cells(startRow, valueCol), ws.Cells(lastRow, valueCol)).Value
Dim outputSize As Long
outputSize = ((UBound(inputArr, 1) - 1) * UBound(inputArr, 1)) / 2
Dim outputIndex As Long
Dim outputArr As Variant
ReDim outputArr(1 To outputSize, 1 To 1) As Variant
Dim i As Long
Dim n As Long
Dim currFirst As Long
Dim currLowest As Long
For i = 2 To UBound(inputArr, 1)
currFirst = inputArr(i, 1)
currLowest = currFirst - inputArr(i - 1, 1)
For n = i - 1 To 1 Step -1
Dim testLowest As Long
testLowest = currFirst - inputArr(n, 1)
If testLowest < currLowest Then currLowest = testLowest
outputIndex = outputIndex + 1
outputArr(outputIndex, 1) = currLowest
Next n
Next i
ws.Cells(startRow, outputCol).Resize(UBound(outputArr, 1)).Value = outputArr
End Sub
代码说明:(数据集仅用于视觉目的) 代码计算列(例如列 B)中的值并创建 array1 并将数组插入结果列。
我想要实现的是重复此代码/循环 n 次并创建动态数量的数组,然后将这些数组的结果放入 Result 列。我不知道如何在一个循环中创建一个 array1 然后 array2 等等。
一列可能有 60k+ 行,因此我需要非常轻量级的解决方案来实现最短运行时间。
感谢您的帮助。
编辑:
添加图片
【问题讨论】:
在计算当前数组时,如果不依赖多个数组,为什么还需要多个数组?将整个过程主体包裹在For n = 1 to n
/Next
中。
@GSerg 但是我会一直替换array1,不是吗?例如,我需要创建 10 个数组,然后比较其中的值。
列的长度是否不同?
@CDP1802 长度相同,数组大小相同
给定您的数据集,您可以使用公式获取结果列。并且有一些方法可以使其适应不同大小的数据集。
【参考方案1】:
这假定您的日期和值始终成对出现,因此您使用的列始终是偶数。
基本上添加了另一个循环来遍历列,并在每列计算结束时,将outputArr
添加到Collection
(outputColl
) 中。我在最后添加了如何迭代集合和每个数组的行的示例。
Option Explicit
Private Sub Test()
Const startRow As Long = 2
Const firstValueCol As Long = 2
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long
Dim lastCol As Long
With ws
lastRow = .Cells(.Rows.Count, firstValueCol).End(xlUp).Row
lastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
End With
Dim outputSize As Long
outputSize = ((lastRow - startRow) * (lastRow - startRow + 1)) / 2
Dim outputArr As Variant
ReDim outputArr(1 To outputSize, 1 To 1) As Variant
Dim outputColl As Collection
Set outputColl = New Collection
Dim x As Long
Dim i As Long
Dim n As Long
For x = firstValueCol To lastCol Step 2
Dim inputArr As Variant
inputArr = ws.Range(ws.Cells(startRow, x), ws.Cells(lastRow, x)).Value
Dim outputIndex As Long
outputIndex = 0
For i = 2 To UBound(inputArr, 1)
Dim currFirst As Long
Dim currLowest As Long
currFirst = inputArr(i, 1)
currLowest = currFirst - inputArr(i - 1, 1)
For n = i - 1 To 1 Step -1
Dim testLowest As Long
testLowest = currFirst - inputArr(n, 1)
If testLowest < currLowest Then currLowest = testLowest
outputIndex = outputIndex + 1
outputArr(outputIndex, 1) = currLowest
Next n
Next i
outputColl.Add outputArr
Next x
'Loop through your collection
For x = 1 To outputColl.Count
'loop through the rows in the array
For i = 1 To UBound(outputColl(x), 1)
'Do your math here
Debug.Print outputColl(x)(i, 1)
Next i
Next x
'Dim outputCol As Long
'outputCol = lastCol + 1
'ws.Cells(startRow, outputCol).Resize(UBound(outputArr, 1)).Value = outputArr
End Sub
【讨论】:
【参考方案2】:总结结果数组
Option Explicit
' 1448 rows in source will generate 1047629 rows in destination,
' which takes about 6-7 seconds for 10 columns.
Sub WriteTricky()
' Needs 'GetTricky' and 'SumUpTwoArrays'.
Dim dTime As Double: dTime = Timer ' time measuring
' Source
Const sName As String = "Sheet1"
Const sColsList As String = "B,D,F,H,J,L,N,P,R,T"
Const slrCol As String = "B" ' Last Row Column
Const sfRow As Long = 2 ' First Row
' Destination
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "V2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Create a reference to the source last (one-column) range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
Dim srCount As Long: srCount = slRow - sfRow + 1
If srCount < 2 Then Exit Sub
Dim drCount As Long: drCount = (srCount - 1) * srCount / 2
If sws.Rows.Count - drCount - sfRow + 1 < 0 Then Exit Sub ' will not fit
Dim slrcrg As Range: Set slrcrg = sws.Cells(sfRow, slrCol).Resize(srCount)
' Write the 'tricky' values to the destination array.
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim nUpper As Long: nUpper = UBound(sCols)
Dim dData As Variant
Dim aData As Variant
Dim scrg As Range
Dim n As Long
For n = 0 To UBound(sCols)
Set scrg = slrcrg.EntireRow.Columns(sCols(n))
If n > 0 Then
aData = GetTricky(scrg)
SumUpTwoArrays dData, aData
Else
dData = GetTricky(scrg)
End If
Next n
' Write values from destination array to the destination (one-column) range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirstCellAddress)
Dim dcrg As Range: Set dcrg = dfcell.Resize(UBound(dData))
dcrg.Value = dData
Debug.Print Timer - dTime ' time measuring
End Sub
' This is Raymond Wu's logic transferred to a function.
Function GetTricky( _
ColumnRange As Range) _
As Variant
If ColumnRange Is Nothing Then Exit Function
Dim sData As Variant
Dim srCount As Long
With ColumnRange.Columns(1)
srCount = .Rows.Count
If srCount = 1 Then Exit Function
sData = .Value
End With
Dim drCount As Long: drCount = (srCount - 1) * srCount / 2
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim sr As Long
Dim sn As Long
Dim currFirst As Long
Dim currLowest As Long
Dim testLowest As Long
Dim dr As Long
For sr = 2 To srCount
currFirst = sData(sr, 1)
currLowest = currFirst - sData(sr - 1, 1)
For sn = sr - 1 To 1 Step -1
testLowest = currFirst - sData(sn, 1)
If testLowest < currLowest Then currLowest = testLowest
dr = dr + 1
dData(dr, 1) = currLowest
Next sn
Next sr
GetTricky = dData
End Function
Sub SumUpTwoArrays( _
ByRef SumData As Variant, _
ByVal AddData As Variant) ' note 'ByRef' i.e. 'SumData' will be modified
Dim aValue As Variant
Dim r As Long
For r = 1 To UBound(AddData)
aValue = AddData(r, 1)
If IsNumeric(aValue) Then
If aValue <> 0 Then
SumData(r, 1) = SumData(r, 1) + aValue
End If
End If
Next r
End Sub
【讨论】:
2008,感谢您的评论,代码运行良好。但是我需要对更多的列、数组进行数学运算(你的只是对两个数组求和),而且代码相当高级,在我的学习阶段很难理解。我无法根据需要修改代码:( 它汇总了与sColsList
中的列字符串一样多的数组(列)。您能否分享有关您正在尝试做的事情的更多详细信息,即您需要纯列还是需要使用棘手的代码处理这些列,例如在锯齿状数组(数组数组)中?
添加图片以便更好地理解,VBasic 2008。以上是关于如何在 VBA 中创建 n 个数组的主要内容,如果未能解决你的问题,请参考以下文章
如何使用 VBA 将事件添加到运行时在 Excel 中创建的控件
如何使用 VBA 在 ms 访问表单中创建自定义自动编号? [关闭]