VBA Excel 二维数组
Posted
技术标签:
【中文标题】VBA Excel 二维数组【英文标题】：VBA Excel 2-Dimensional Arrays 【发布时间】：2011-03-09 21:01:42 【问题描述】：我试图找出如何声明二维数组，但到目前为止我发现的所有示例都是用集合整数声明的。我正在尝试创建一个程序，该程序将利用两个二维数组，然后对这些数组执行简单的操作（例如查找差异或百分比）。数组由 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) 那样声明它，因为那样我会得到一个越界异常。
谢谢，
杰西·斯莫莫
【问题讨论】：
按照 iDevlop 的回答使用变体数组。它们是为 Excel 中的范围制作的。 【参考方案1】：事实上，我不会使用任何 REDIM，也不会使用循环将数据从工作表传输到数组：
dim arOne()
arOne = range("A2:F1000")
甚至
arOne = range("A2").CurrentRegion
就是这样，你的数组填充速度比循环快得多，没有 redim。
【讨论】：
+1 我同意这是一种更好的方法。我天真地处理了语法错误。 这是最好的办法，需要指出的是dim语句默认使用Variant。 我不知道宏开始运行之前的尺寸是多少。感谢您的回复 在我的身上测试过，它至少和 ReDim 做的一样，而且看起来确实更快。快速提问，我可以使用这个 CurrentRegion 来用数组填充特定空间吗？所以它可能看起来像 Range("A2").CurrentRegion = arTwo 其中 arTwo 是一些数组。谢谢 我在 CurrentRegion 上阅读了更多内容，我是否正确，它只是突出显示该区域还是将值存储到数组中（这里需要一个二维数组）？【参考方案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
【讨论】：
谢谢，它似乎在工作，但我无法确定，因为我实际上看不到里面有什么。您知道如何将值打印到单元格中吗？这是我到目前为止所拥有的： ActiveWorkbook.Sheets(firstSheetName).Copy Before:=ActiveWorkbook.Sheets(firstSheetName) For iRow = 1 To totalRow For iCol = 1 To totalCol ActiveSheet.Cells(iRow, iCol) = answerArray(iRow, iCol ) Next iCol Next iRow 但这实际上并没有输出任何东西 @Jesse 尝试我的编辑，将 if 填充到空工作表中的代码中，然后按 F5！ @David 遇到了一个奇怪的错误。我的测试网格从 1 变为 324，尺寸为 9 x 36（第二个网格从 324 变为 1）。我严格更改您的代码以适合我的代码，所以除了名称不同之外没有什么大的不同。到目前为止，它似乎只是复制了我的第一个网格，然后有一个消息框显示“无法执行请求的操作”。谢谢 @Jesse 好吧，我猜不出是什么原因，一定是你的代码有问题。无论如何，你应该按照@iDevelop的方式去做，它会更容易和更快！ @Jesse 对于它的价值，我已经更新了我的答案以包含一个基于范围的版本。【参考方案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 操作和指针算法调用任何函数。
【讨论】：
+1 表示“你应该在击中工作表之前尽一切可能”和 +1 表示我在 SO 上看到的最庞大的帖子.. 至少在 VBA 部分. @iDevlop ...是的，所有的东西。部分原因是 VBA 不是一种简洁的语言。大多数情况下，我们不是将参数传递给由开发人员编写的定义良好的函数，而是与用户界面交互 - 一个可以包含任何数据类型和各种错误的网格 - 这需要大量的防御性编码。跨度> @Nile：我在开玩笑。与我给***.com/a/5252452/78522 的“单线解决方案”相比，我没有真正看到附加值 @iDevlop - 如果你只做过一次，附加值是负的。如果您每年开发超过一百种战术工具，将数据转储到任何地方的范围内，并且您必须支持它们，具有内置弹性的代码的价值是相当可观的。对于战术开发人员来说，最重要的生产力指标不是行输出，而是每行代码的持续工作量。【参考方案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
【讨论】：
以上是关于VBA Excel 二维数组的主要内容，如果未能解决你的问题，请参考以下文章
如何在 Excel 中显示来自 Access 的二维数组记录集？