Arrays Excel VBA-如何重新定义二维阵列？

通过VisualBasic在Excel中，我正在迭代加载到Excel中的发票CSV文件。客户以可确定的模式开具发票

我将它们读入一个动态2D数组，然后将它们写入另一个具有旧发票的工作表。我知道我必须反转行和列，因为只有数组的最后一个维度可以被重排，然后在我将其写入主工作表时进行转置

在某个地方，我的语法错了。它一直告诉我我已经对数组进行了尺寸化。不知怎的，我创建了一个静态数组？为了让它动态运行，我需要修复什么

给出的每个答案的工作代码

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

子发票支持日期（）
'
'应用程序设置
Application.ScreenUpdating=False
Application.DisplayAlerts=False
Application.Calculation=xlCalculationManual
'实例化控制变量
Dim allRows为长，currentOffset为长，invoiceActive为布尔值，mAllRows为长
Dim IALLOWS为长，unusedRow为长，row为长，MWS SEXISTISTERS为布尔值，NEWMALROWS为长
'实例化发票变量
Dim accountNum作为字符串，custName作为字符串，vinNum作为字符串，caseNum作为字符串，STATUSSFIELD作为字符串
Dim invDate为字符串，makeField为字符串，feeDesc为字符串，amountField为字符串，invNum为字符串
'实例化工作簿变量
将mWB设置为工作簿的主控形状
将iWB设置为工作簿的导入
'实例化工作表变量
Dim mWS作为工作表
将iWS设置为工作表
'实例化范围变量
暗iData作为范围
'初始化变量
invoiceActive=False
行=0
'打开导入工作簿
工作簿。打开（“路径：excel\u invoices.csv”）
设置iWB=ActiveWorkbook
设置iWS=iWB.Sheets（“excel\u invoices.csv”）
激活
范围（“A1”）。选择
iAllRows=iWS.UsedRange.Rows.Count“计算导入数据的行数”
'实例化数组，为客户端名称包含额外的列
小额发票（）
重拨发票（10，0）
'通过行循环。
做
'检查客户端的开始并存储客户端名称
如果ActiveCell.Value=“账号”，则
clientName=ActiveCell.Offset（-1,6）.Value
如果结束
如果ActiveCell.Offset（0,3）.Value为空，ActiveCell.Value“Account Number”和ActiveCell.Offset（2,0）=空，则
invoiceActive=True
'填充帐户信息。
accountNum=ActiveCell.Offset（0,0）.Value
vinNum=ActiveCell.Offset（0，1）.Value
'出于FDCPA原因，省略客户名称
caseNum=ActiveCell.Offset（0,3）.Value
statusField=ActiveCell.Offset（0,4）.Value
invDate=ActiveCell.Offset（0,5）.Value
makeField=ActiveCell.Offset（0,6）.Value
如果结束
如果invoiceActive=True，ActiveCell.Value=Empty，ActiveCell.Offset（0,6）。Value=Empty，ActiveCell.Offset（0,9）。Value=Empty，则
'确保开具的发票不是0美元
如果ActiveCell.Offset（0,8）.Value为0，则
'填充单个项目值。
feeDesc=ActiveCell.Offset（0,7）.Value
amountField=ActiveCell.Offset（0,8）.Value
invNum=ActiveCell.Offset（0,10）.Value
'将数据传输到阵列
发票（0，行）=今天（）
发票（第1行）=accountNum
发票（第2行）=客户名称
发票（第3行）=vinNum
发票（第4行）=案例数量
发票（第5行）=状态字段
发票（第6行）=发票日期
发票（第7行）=makeField
发票（第8行）=feeDesc
发票（第9行）=金额字段
发票（第10行）=invNum
'数组的增量行计数器
行=行+1
'为下一个条目调整数组大小
重拨保留发票（第10行）
如果结束
如果结束
'查找发票的结尾
如果invoiceActive=True且ActiveCell.Offset（0,9）为空，则
'将标志设置为发票外部
invoiceActive=False
如果结束
'将活动单元格增加到下一个单元格
ActiveCell.Offset（1，0）.激活
'在最后使用的行定义循环结束
循环直到ActiveCell.row=iAllRows
'关闭导入数据文件
iWB，结束

这不太直观，但如果使用尺寸将阵列调暗，则无法对其进行重新分配。链接页面的确切报价为：

ReDim语句用于调整具有以下属性的动态数组的大小： 已使用私有、公共或Dim正式声明 带有空括号的语句（不带维度下标）

换句话说，不是

dim发票（10,0）

你应该使用

Dim invoices()
Redim invoices(10,0)

然后，当您重拨时，您需要使用

redimpreserve（第10行）

---

警告：重新确定多维数组的尺寸时，如果要保留值，只能增加最后一个尺寸。也就是说，

Redim Preserve（11，row）

甚至

（11,0）

都会失败。

我自己在遇到这个路障时偶然发现了这个问题。最后，我写了一段代码，非常快速地在一个新大小的数组（第一维或最后维）上处理这个

ReDim Preserve

。也许它会帮助其他面临同样问题的人

因此，对于用法，假设您最初将数组设置为

MyArray（3,5）

，并且您希望使维度（第一个也是！）更大，只需对

MyArray（10,20）

。你会习惯做这样的事，对吗

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

现在数组变大了，数据也保留了下来。多维数组的

ReDim Preserve

已完成：

最后但并非最不重要的是神奇的函数：

redimprefer（）

---

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

这是红色的最新代码

 MyArray = ReDimPreserve(MyArray,10,20)

'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

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

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

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

ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)

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

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