如何在 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 中创建具有动态行源的列表框

如何使用 VBA 将事件添加到运行时在 Excel 中创建的控件

如何使用 VBA 在 ms 访问表单中创建自定义自动编号? [关闭]

VBA - 如何在数组中创建队列? (FIFO)先进先出

如何在 VBA 中创建一个函数以返回与记录集中每条记录的特定条件匹配的列名?

如何更改在VBA中创建的下拉列表的字体大小和格式