VBA Excel 二维数组

Question

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

由于我不知道有多少行或列，我打算使用变量。

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

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

谢谢，

杰西·斯莫莫

Answer 1

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

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

甚至

arOne = range("A2").CurrentRegion

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

Answer 2

你需要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

---

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

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

Answer 3

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

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

其中一个主要组成部分是错误捕获，我过去常常看到它无处不在。我讨厌重复的编码：我已经在这里全部编码了，而且 - 希望 - 你再也不用写了。

VBA 'Array to Range' 函数

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

您需要 ArrayDimensions 的来源：

模块头中需要此 API 声明：

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

...这是函数本身：

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

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

Answer 4

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

要运行我的示例，您需要用一些值填充 Sheet1 中的 A 和 B 列。然后运行 ​​test()。它将首先读取两行并将值添加到BigArr。然后它会检查你有多少行数据，并从它停止读取的地方，即第 3 行读取它们。

在 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