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

【问题标题】：Excel VBA - How to Redim a 2D array?Excel VBA - 如何重新设置二维数组？
【发布时间】：2012-10-22 10:27:40
【问题描述】：

在通过 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

【问题讨论】：

为什么不使用invoices = Range("A1").CurrentRegion 而不是循环？此外，所有这些 Select 和 ActiveCell 都很慢，很容易避免。

标签： arrays excel vba multidimensional-array

【解决方案1】：

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

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

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

你应该使用

Dim invoices()
Redim invoices(10,0)

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

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

【讨论】：

谢谢，这为我解决了一些困惑。这是我第一次在VB中使用数组。

【解决方案2】：

我在自己遇到这个路障时偶然发现了这个问题。我最终写了一段代码来快速处理这个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 分钟内写完这篇文章，因此无法保证。但是，如果您想使用或扩展它，请随意。我原以为有人已经在这里有了这样的代码，显然不是。所以，你们去吧，齿轮头们。

【讨论】：

看起来是个不错的解决方案。我也会尝试将其添加到我的代码中。希望它不会影响性能，因为我打算在循环中使用它。
这对我有用。但是请记住，这个函数没有声明任何变量，因此它的数组被声明为Variants。所以要确保你想要ReDim的数组也被声明为Variant，或者你声明函数的变量，使它们与你的数组的声明类型相匹配。

【解决方案3】：

这里是带有变量声明的 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

【讨论】：

【解决方案4】：

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

与其再次转置、重新调整和转置，如果我们谈论二维数组，为什么不只存储转置后的值。在这种情况下， 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 等等。

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

【讨论】：

虽然这并没有明确回答问题，但它为整体问题提供了更有效的解决方案。谢谢。

【解决方案5】：

这是我的做法。

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

【讨论】：

【解决方案6】：

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

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

【讨论】：

【解决方案7】：

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

ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)

到：

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

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

【讨论】：

【解决方案8】：

给你。

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

【讨论】：

【解决方案9】：

你可以这样做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

【讨论】：