VBA Excel二维数组
我试图找出如何声明一个二维数组，但我迄今为止发现的所有例子都是用set整数声明的。 我试图创build一个程序，将利用两个二维数组，然后对这些数组（如发现差异或百分比）执行简单的操作。 数组由Excel表格中的数字填充（一组数字在Sheet1上，另一组在Sheet2上，两组数据具有相同的行数和列数）。
因为我不知道有多less行或列有我要使用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 当我试图运行这个时，我得到一个编译时错误在“Dim s2Array（totalRow，totalCol）”说，一个常量expression式是必需的。 如果将其更改为“Dim s2Array（1 to totalRow，1 to totalCol）”，则会发生同样的错误。 因为我不知道什么尺寸是从开始我不能声明它像“Dim s2Array（1，1）”，因为那样我会得到一个界外的例外。
谢谢，
Jesse Smothermon
实际上，我不会使用任何REDIM，也不会将数据从一个表单传输到一个表单：
dim arOne() arOne = range("A2:F1000")
甚至
arOne = range("A2").CurrentRegion
就是这样，你的数组被填充得快得多，然后循环，没有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
正如其他人已经指出的，你的实际问题可以用范围来解决。 你可以尝试这样的事情：
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
这里是一个通用的VBA数组范围函数 ，它将一个数组写入到工作表中。 这比将数据一次写入一个单元格中的行和列的循环速度要快得多。但是，需要做一些维护工作，因为您必须正确指定目标范围的大小。
这个“家务”看起来像很多工作，可能相当慢，但这是写入表单的“最后一英里”代码，而且一切都比写入工作表更快。 或者至less比速度快得多，甚至是在VBA中读取或写入工作表的速度都相当快，而且在打开表单之前，您应该尽可能以代码的forms进行操作。
其中一个主要的组成部分是我曾经看到的到处都是的错误陷阱。 我讨厌重复的编码：我把它编码在这里，希望 – 你永远不需要再写一遍。
VBA“arrays到范围”function
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)
…这是function本身：
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 RB 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
另外：我build议你把这个声明保密。 如果您必须在另一个模块中将其设置为公共Sub，请将Option Private Module语句插入到模块标题中。 你真的不希望你的用户用CopyMemoryoperations和指针算术来调用任何函数。
对于这个例子，你将需要创build自己的types，这将是一个数组。 然后你创build一个更大的数组，其中的元素是你刚创build的types。
为了运行我的例子，你将需要用Sheet1填充Sheet1中的列A和B。 然后运行test（） 。 它将读取前两行并将值添加到BigArr 。 然后它会检查你有多less行数据，并从停止读取的地方，即第三行读取它们。
在Excel 2007中testing。
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