arrays - Excel VBA - 如何重新设置二维数组？

Question

在通过 Visual Basic 的 Excel 中，我正在遍历加载到 Excel 中的 CSV 发票文件。发票是由客户确定的模式。

我正在将它们读入一个动态二维数组，然后将它们写入另一个带有旧发票的工作表。我知道我必须反转行和列，因为只有数组的最后一个维度可能会被重新调整，然后在我将其写入主工作表时转置。

在某处，我的语法错误。它一直告诉我我已经对数组进行了维度化。我以某种方式将其创建为静态数组？为了让它动态运行，我需要修复什么？

每个答案的工作代码

Sub InvoicesUpdate()
'
'Application Settings
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

'Instantiate control variables
Dim allRows As Long, currentOffset As Long, invoiceActive As Boolean, mAllRows As Long
Dim iAllRows As Long, unusedRow As Long, row As Long, mWSExists As Boolean, newmAllRows As Long

'Instantiate invoice variables
Dim accountNum As String, custName As String, vinNum As String, caseNum As String, statusField As String
Dim invDate As String, makeField As String, feeDesc As String, amountField As String, invNum As String

'Instantiate Workbook variables
Dim mWB As Workbook 'master
Dim iWB As Workbook 'import

'Instantiate Worksheet variables
Dim mWS As Worksheet
Dim iWS As Worksheet

'Instantiate Range variables
Dim iData As Range

'Initialize variables
invoiceActive = False
row = 0

'Open import workbook
Workbooks.Open ("path:excel_invoices.csv")
Set iWB = ActiveWorkbook
Set iWS = iWB.Sheets("excel_invoices.csv")
iWS.Activate
Range("A1").Select
iAllRows = iWS.UsedRange.Rows.Count 'Count rows of import data

'Instantiate array, include extra column for client name
Dim invoices()
ReDim invoices(10, 0) 

'Loop through rows.
Do

    'Check for the start of a client and store client name
    If ActiveCell.Value = "Account Number" Then

        clientName = ActiveCell.Offset(-1, 6).Value

    End If

    If ActiveCell.Offset(0, 3).Value <> Empty And ActiveCell.Value <> "Account Number" And ActiveCell.Offset(2, 0) = Empty Then

        invoiceActive = True

        'Populate account information.
        accountNum = ActiveCell.Offset(0, 0).Value
        vinNum = ActiveCell.Offset(0, 1).Value
        'leave out customer name for FDCPA reasons
        caseNum = ActiveCell.Offset(0, 3).Value
        statusField = ActiveCell.Offset(0, 4).Value
        invDate = ActiveCell.Offset(0, 5).Value
        makeField = ActiveCell.Offset(0, 6).Value

    End If

    If invoiceActive = True And ActiveCell.Value = Empty And ActiveCell.Offset(0, 6).Value = Empty And ActiveCell.Offset(0, 9).Value = Empty Then

        'Make sure something other than $0 was invoiced
        If ActiveCell.Offset(0, 8).Value <> 0 Then

            'Populate individual item values.
            feeDesc = ActiveCell.Offset(0, 7).Value
            amountField = ActiveCell.Offset(0, 8).Value
            invNum = ActiveCell.Offset(0, 10).Value

            'Transfer data to array
            invoices(0, row) = "=TODAY()"
            invoices(1, row) = accountNum
            invoices(2, row) = clientName
            invoices(3, row) = vinNum
            invoices(4, row) = caseNum
            invoices(5, row) = statusField
            invoices(6, row) = invDate
            invoices(7, row) = makeField
            invoices(8, row) = feeDesc
            invoices(9, row) = amountField
            invoices(10, row) = invNum

            'Increment row counter for array
            row = row + 1

            'Resize array for next entry
            ReDim Preserve invoices(10,row)

         End If

    End If

    'Find the end of an invoice
    If invoiceActive = True And ActiveCell.Offset(0, 9) <> Empty Then

        'Set the flag to outside of an invoice
        invoiceActive = False

    End If

    'Increment active cell to next cell down
    ActiveCell.Offset(1, 0).Activate

'Define end of the loop at the last used row
Loop Until ActiveCell.row = iAllRows

'Close import data file
iWB.Close

score 48 · Accepted Answer

这并不完全直观，但是如果您使用尺寸调暗数组，则无法 Redim (VB6 Ref)数组。链接页面的确切报价是：

ReDim 语句用于调整已使用带空括号（无维度下标）的 Private、Public 或 Dim 语句正式声明的动态数组的大小或调整其大小。

换句话说，而不是dim invoices(10,0)

你应该使用

Dim invoices()
Redim invoices(10,0)

然后当你 ReDim 时，你需要使用Redim Preserve (10,row)

警告：在对多维数组进行重维时，如果要保留值，则只能增加最后一维。IERedim Preserve (11,row)甚至(11,0)会失败。

score 16 · Accepted Answer

我自己碰到这个路障时偶然发现了这个问题。我最终写了一段代码来快速处理ReDim Preserve一个新大小的数组（第一个或最后一个维度）。也许它会帮助其他面临同样问题的人。

因此，对于用法，假设您的数组最初设置为 MyArray(3,5)，并且您想让尺寸（首先！）更大，让我们说MyArray(10,20)。你会习惯做这样的事情吗？

 ReDim Preserve MyArray(10,20) '<-- Returns Error

但不幸的是，这会返回错误，因为您试图更改第一个维度的大小。因此，使用我的功能，您只需执行以下操作：

 MyArray = ReDimPreserve(MyArray,10,20)

现在数组变大了，数据也被保留了。您ReDim Preserve的多维数组已完成。:)

最后但并非最不重要的是，神奇的功能：ReDimPreserve()

'redim preserve both dimensions for a multidimension array *ONLY
Public Function ReDimPreserve(aArrayToPreserve,nNewFirstUBound,nNewLastUBound)
    ReDimPreserve = False
    'check if its in array first
    If IsArray(aArrayToPreserve) Then       
        'create new array
        ReDim aPreservedArray(nNewFirstUBound,nNewLastUBound)
        'get old lBound/uBound
        nOldFirstUBound = uBound(aArrayToPreserve,1)
        nOldLastUBound = uBound(aArrayToPreserve,2)         
        'loop through first
        For nFirst = lBound(aArrayToPreserve,1) to nNewFirstUBound
            For nLast = lBound(aArrayToPreserve,2) to nNewLastUBound
                'if its in range, then append to new array the same way
                If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
                    aPreservedArray(nFirst,nLast) = aArrayToPreserve(nFirst,nLast)
                End If
            Next
        Next            
        'return the array redimmed
        If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
    End If
End Function

我在 20 分钟内写了这篇文章，所以不能保证。但是，如果您想使用或扩展它，请随意。我原以为有人已经在这里有了这样的代码，显然不是。所以在这里你去齿轮头。

score 5 · Accepted Answer

这是带有 variabel 声明的 redim preseve 方法的更新代码，希望 @Control Freak 可以使用它:)

Option explicit
'redim preserve both dimensions for a multidimension array *ONLY
Public Function ReDimPreserve(aArrayToPreserve As Variant, nNewFirstUBound As Variant, nNewLastUBound As Variant) As Variant
    Dim nFirst As Long
    Dim nLast As Long
    Dim nOldFirstUBound As Long
    Dim nOldLastUBound As Long

    ReDimPreserve = False
    'check if its in array first
    If IsArray(aArrayToPreserve) Then
        'create new array
        ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)
        'get old lBound/uBound
        nOldFirstUBound = UBound(aArrayToPreserve, 1)
        nOldLastUBound = UBound(aArrayToPreserve, 2)
        'loop through first
        For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
            For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound
                'if its in range, then append to new array the same way
                If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
                    aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)
                End If
            Next
        Next
        'return the array redimmed
        If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
    End If
End Function

score 5 · Accepted Answer

我知道这有点老了，但我认为可能有一个更简单的解决方案，不需要额外的编码：

而不是再次转置，重新调整和转置，如果我们谈论二维数组，为什么不只存储转置的值开始。在这种情况下， redim preserve 实际上从一开始就增加了右（第二个）维度。或者换句话说，为了可视化它，如果只有列的 nr 可以用 redim preserve 增加，为什么不存储在两行而不是两列中。

索引将是 00-01、01-11、02-12、03-13、04-14、05-15 ... 0 25-1 25 等等，而不是 00-01、10-11、20-21 , 30-31, 40-41 等等。

由于在重新调整时只能保留第二个（或最后一个）维度，因此有人可能会争辩说这就是数组应该如何开始使用的方式。我在任何地方都没有看到这个解决方案，所以也许我忽略了一些东西？

score 2 · Accepted Answer

这是我如何做到这一点的。

Dim TAV() As Variant
Dim ArrayToPreserve() as Variant

TAV = ArrayToPreserve
ReDim ArrayToPreserve(nDim1, nDim2)
For i = 0 To UBound(TAV, 1)
    For j = 0 To UBound(TAV, 2)
        ArrayToPreserve(i, j) = TAV(i, j)
    Next j
Next i

score 2 · Accepted Answer

给你。

Public Function ReDimPreserve(ByRef Arr, ByVal idx1 As Integer, ByVal idx2 As Integer)

    Dim newArr()
    Dim x As Integer
    Dim y As Integer

    ReDim newArr(idx1, idx2)

    For x = 0 To UBound(Arr, 1)
        For y = 0 To UBound(Arr, 2)
            newArr(x, y) = Arr(x, y)
        Next
    Next

    Arr = newArr

End Function

score 1 · Accepted Answer

对@controlfreak 和@skatun 之前写的内容的一个小更新（对不起，我没有足够的声誉来发表评论）。我使用了 skatun 的代码，它对我来说效果很好，只是它创建了一个比我需要的更大的数组。因此，我改变了：

ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)

到：

ReDim aPreservedArray(LBound(aArrayToPreserve, 1) To nNewFirstUBound, LBound(aArrayToPreserve, 2) To nNewLastUBound)

这将保持两个维度的原始数组的下限（0、1 或其他任何值；原始代码假定为 0）。

score 0 · Accepted Answer

我以更短的方式解决了这个问题。

Dim marray() as variant, array2() as variant, YY ,ZZ as integer
YY=1
ZZ=1

Redim marray(1 to 1000, 1 to 10)
Do while ZZ<100 ' this is populating the first array
marray(ZZ,YY)= "something"
ZZ=ZZ+1
YY=YY+1 
Loop
'this part is where you store your array in another then resize and restore to original
array2= marray
Redim marray(1 to ZZ-1, 1 to YY)
marray = array2

score 0 · Accepted Answer

你可以这样做array(0)= array(0,1,2,3)。

Sub add_new(data_array() As Variant, new_data() As Variant)
    Dim ar2() As Variant, fl As Integer
    If Not (isEmpty(data_array)) = True Then
        fl = 0
    Else
        fl = UBound(data_array) + 1
    End If
    ReDim Preserve data_array(fl)
    data_array(fl) = new_data
End Sub

Sub demo()
    Dim dt() As Variant, nw(0, 1) As Variant
    nw(0, 0) = "Hi"
    nw(0, 1) = "Bye"
    Call add_new(dt, nw)
    nw(0, 0) = "Good"
    nw(0, 1) = "Bad"
    Call add_new(dt, nw)
End Sub

arrays - Excel VBA - 如何重新设置二维数组？

9 回答 9

Related

Reference