VBA Excel 二维数组

VBA Excel 2-Dimensional Arrays

提问by Jesse Smothermon

I was trying to find out how to declare a 2-Dimensional array but all of the examples I have found so far are declared with set integers. I'm trying to create a program that will utilize two 2-Dimensional arrays and then perform simple operations on those arrays (such as finding difference or percent). The arrays are populated by numbers in Excel sheets (one set of numbers is on Sheet1 and another set is on Sheet2, both sets have the same number of rows and columns).

我试图找出如何声明一个二维数组，但到目前为止我发现的所有例子都是用集合整数声明的。我正在尝试创建一个程序，该程序将利用两个二维数组，然后对这些数组执行简单的操作（例如查找差异或百分比）。数组由 Excel 工作表中的数字填充（一组数字在 Sheet1 上，另一组在 Sheet2 上，两组具有相同的行数和列数）。

Since I don't know how many rows or columns there are I was going to use variables.

因为我不知道有多少行或列，所以我打算使用变量。

Dim s1excel As Worksheet
Dim s2excel As Worksheet
Dim s3excel As Worksheet
Dim firstSheetName As String
Dim secondSheetName As String
Dim totalRow As Integer
Dim totalCol As Integer
Dim iRow As Integer
Dim iCol As Integer

Set s1excel = ThisWorkbook.ActiveSheet

' Open the "Raw_Data" workbook
Set wbs = Workbooks.Open(file_path & data_title)
wbs.Activate
ActiveWorkbook.Sheets(firstSheetName).Select
Set s2excel = wbs.ActiveSheet

' Find totalRow, totalColumn (assumes there's values in Column A and Row 1 with no blanks)
totalRow = ActiveSheet.Range("A1").End(xlDown).Row
totalCol = ActiveSheet.Range("A1").End(xlToRight).Column

Dim s2Array(totalRow, totalCol)
Dim s3Array(totalRow, totalCol)

For iRow = 1 To totalRow
    For iCol = 1 To totalCol
        s2Array(iRow, iCol) = Cells(iRow, iCol)
    Next iCol
Next iRow

ActiveWorkbook.Sheets(secondSheetName).Select
Set s3excel = wbs.ActiveSheet

For iRow = 1 To totalRow
    For iCol = 1 To totalCol
        s3Array(iRow, iCol) = Cells(iRow, iCol)
    Next iCol
Next iRow

When I attempt to run this I get a compile-time error at the Dim s2Array(totalRow, totalCol)saying that a constant expression is required. The same error occurs if I change it to Dim s2Array(1 To totalRow, 1 To totalCol). Since I don't know what the dimensions are from the get go I can't declare it like Dim s2Array(1, 1)because then I'll get an out-of-bounds exception.

当我尝试运行它时，我收到一个编译时错误，Dim s2Array(totalRow, totalCol)说需要一个常量表达式。如果我将其更改为Dim s2Array(1 To totalRow, 1 To totalCol). 因为我不知道从一开始的尺寸是多少，所以我不能声明它，Dim s2Array(1, 1)因为那样我会得到一个越界异常。

Thank you,

谢谢，

Jesse Smothermon

杰西·斯莫瑟蒙

回答by Patrick Honorez

In fact I would not use any REDIM, nor a loop for transferring data from sheet to array:

事实上，我不会使用任何 REDIM，也不会使用循环将数据从工作表传输到数组：

dim arOne()
arOne = range("A2:F1000")

or even

甚至

arOne = range("A2").CurrentRegion

and that's it, your array is filled much faster then with a loop, no redim.

就是这样，你的数组填充速度比循环快得多，没有 redim。

回答by David Heffernan

You need ReDim:

你需要ReDim：

m = 5
n = 8
Dim my_array()
ReDim my_array(1 To m, 1 To n)
For i = 1 To m
  For j = 1 To n
    my_array(i, j) = i * j
  Next
Next

For i = 1 To m
  For j = 1 To n
    Cells(i, j) = my_array(i, j)
  Next
Next

---

---

As others have pointed out, your actual problem would be better solved with ranges. You could try something like this:

正如其他人指出的那样，使用范围可以更好地解决您的实际问题。你可以尝试这样的事情：

Dim r1 As Range
Dim r2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
totalRow = ws1.Range("A1").End(xlDown).Row
totalCol = ws1.Range("A1").End(xlToRight).Column

Set r1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(totalRow, totalCol))
Set r2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(totalRow, totalCol))
r2.Value = r1.Value

回答by Nigel Heffernan

Here's A generic VBA Array To Range functionthat writes an array to the sheet in a single 'hit' to the sheet. This is muchfaster than writing the data into the sheet one cell at a time in loops for the rows and columns... However, there's some housekeeping to do, as you must specify the size of the target range correctly.

这是一个通用的 VBA Array To Range 函数，它在对工作表的一次“命中”中将数组写入工作表。这比在行和列的循环中一次将数据写入工作表一个单元格要快得多......但是，有一些内务要做，因为您必须正确指定目标范围的大小。

This 'housekeeping' looks like a lot of work and it's probably rather slow: but this is 'last mile' code to write to the sheet, and everythingis faster than writing to the worksheet. Or at least, so much faster that it's effectively instantaneous, compared with a read or write to the worksheet, even in VBA, and you should do everything you possibly can in code before you hit the sheet.

这个“内务管理”看起来像很多工作，而且可能相当慢：但这是写入工作表的“最后一英里”代码，一切都比写入工作表快。或者至少，与读取或写入工作表相比，甚至在 VBA 中，它的速度要快得多，实际上是即时的，并且您应该在点击工作表之前在代码中做所有可能的事情。

A major component of this is error-trapping that I used to see turning up everywhere . I hate repetitive coding: I've coded it all here, and - hopefully - you'll never have to write it again.

这其中的一个主要组成部分是错误捕获，我曾经看到它随处可见。我讨厌重复编码：我已经在这里编写了所有代码，而且——希望——你永远不必再写一遍。

A VBA 'Array to Range' function

VBA“数组到范围”函数

Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.

On Error Resume Next

'
' Author: Nigel Heffernan
' HTTP://Excellerando.blogspot.com
'
' This code is in te public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on that proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True

If IsEmpty(InputArray) Then
    Exit Sub
End If


If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If

' Is it actually an array? IsArray is sadly broken so...
If Not InStr(TypeName(InputArray), "(") Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)

If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)

ElseIf iDimensions = 1 Then

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iStart = LBound(InputArray)
    iColCount = 1

    If iRowCount > (655354 - rngTarget.Row) Then
        iRowCount = 655354 + iStart - rngTarget.Row
        ReDim Preserve InputArray(iStart To iRowCount)
    End If

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iColCount = 1

    ' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
    ' By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column.
    ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next

    With rngTarget.Worksheet
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
        rngOutput.Value2 = arrTemp
        Set rngTarget = rngOutput
    End With

    Erase arrTemp

ElseIf iDimensions = 2 Then

    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)

    iStart = LBound(InputArray, 1)

    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If


    iStart = LBound(InputArray, 2)
    If iColCount > (254 - rngTarget.Column) Then
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If



    With rngTarget.Worksheet

        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))

        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True

        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)

                    If IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You *have*
                            ' to go back and check, and write this masterpiece one cell at a time...
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
        End If 'err<>0

        If Err <> 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True


        End If 'err<>0


        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time

    End With

End If

End Sub

You will need the source for ArrayDimensions:

您将需要 ArrayDimensions 的源代码：

This API declaration is required in the module header:

模块标头中需要此 API 声明：

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                   (Destination As Any, _
                    Source As Any, _
                    ByVal Length As Long)

...And here's the function itself:

...这是函数本身：

Private Function ArrayDimensions(arr As Variant) As Integer
  '-----------------------------------------------------------------
  ' will return:
  ' -1 if not an array
  ' 0  if an un-dimmed array
  ' 1  or more indicating the number of dimensions of a dimmed array
  '-----------------------------------------------------------------


  ' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' Code written by Chris Rae, 25/5/00

  ' Originally published by R. B. Smissaert.
  ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax

  Dim ptr As Long
  Dim vType As Integer

  Const VT_BYREF = &H4000&

  'get the real VarType of the argument
  'this is similar to VarType(), but returns also the VT_BYREF bit
  CopyMemory vType, arr, 2

  'exit if not an array
  If (vType And vbArray) = 0 Then
    ArrayDimensions = -1
    Exit Function
  End If

  'get the address of the SAFEARRAY descriptor
  'this is stored in the second half of the
  'Variant parameter that has received the array
  CopyMemory ptr, ByVal VarPtr(arr) + 8, 4

  'see whether the routine was passed a Variant
  'that contains an array, rather than directly an array
  'in the former case ptr already points to the SA structure.
  'Thanks to Monte Hansen for this fix

  If (vType And VT_BYREF) Then
    ' ptr is a pointer to a pointer
    CopyMemory ptr, ByVal ptr, 4
  End If

  'get the address of the SAFEARRAY structure
  'this is stored in the descriptor

  'get the first word of the SAFEARRAY structure
  'which holds the number of dimensions
  '...but first check that saAddr is non-zero, otherwise
  'this routine bombs when the array is uninitialized

  If ptr Then
    CopyMemory ArrayDimensions, ByVal ptr, 2
  End If

End Function

Also: I would advise you to keep that declaration private. If you must make it a public Sub in another module, insert the Option Private Modulestatement in the module header. You really don't want your users calling any function with CopyMemoryoperations and pointer arithmetic.

另外：我建议您将该声明保密。如果您必须将其设为另一个模块中的公共 Sub，请Option Private Module在模块标题中插入该语句。您真的不希望您的用户使用 CopyMemory 操作和指针算法调用任何函数。

回答by MP?kalski

For this example you will need to create your own type, that would be an array. Then you create a bigger array which elements are of type you have just created.

对于此示例，您需要创建自己的类型，即数组。然后你创建一个更大的数组，其中的元素是你刚刚创建的类型。

To run my example you will need to fill columns Aand Bin Sheet1with some values. Then run test(). It will read first two rowsand add the values to the BigArr. Then it will check how many rows of data you have and read them all, from the place it has stopped reading, i.e., 3rd row.

要运行我的例子，你需要填写列一个和乙在Sheet1中的一些价值观。然后运行test()。它将读取前两行并将值添加到BigArr。然后它会检查你有多少行数据并从它停止读取的地方读取它们，即第 3 行。

Tested in Excel 2007.

在 Excel 2007 中测试。

Option Explicit
Private Type SmallArr
  Elt() As Variant
End Type

Sub test()
    Dim x As Long, max_row As Long, y As Long
    '' Define big array as an array of small arrays
    Dim BigArr() As SmallArr
    y = 2
    ReDim Preserve BigArr(0 To y)
    For x = 0 To y
        ReDim Preserve BigArr(x).Elt(0 To 1)
        '' Take some test values
        BigArr(x).Elt(0) = Cells(x + 1, 1).Value
        BigArr(x).Elt(1) = Cells(x + 1, 2).Value
    Next x
    '' Write what has been read
    Debug.Print "BigArr size = " & UBound(BigArr) + 1
    For x = 0 To UBound(BigArr)
        Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
    Next x
    '' Get the number of the last not empty row
    max_row = Range("A" & Rows.Count).End(xlUp).Row

    '' Change the size of the big array
    ReDim Preserve BigArr(0 To max_row)

    Debug.Print "new size of BigArr with old data = " & UBound(BigArr)
    '' Check haven't we lost any data
    For x = 0 To y
        Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
    Next x

    For x = y To max_row
        '' We have to change the size of each Elt,
        '' because there are some new for,
        '' which the size has not been set, yet.
        ReDim Preserve BigArr(x).Elt(0 To 1)
        '' Take some test values
        BigArr(x).Elt(0) = Cells(x + 1, 1).Value
        BigArr(x).Elt(1) = Cells(x + 1, 2).Value
    Next x

    '' Check what we have read
    Debug.Print "BigArr size = " & UBound(BigArr) + 1
    For x = 0 To UBound(BigArr)
        Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
    Next x

End Sub