VBA Excel 2-Dimensional Arrays
我试图找出如何声明一个二维数组,但是到目前为止我发现的所有示例都是用集合整数声明的。我正在尝试创建一个程序,它将使用两个二维数组,然后对这些数组执行简单的操作(例如查找差异或百分比)。数组由Excel工作表中的数字填充(一组数字在Sheet1上,另一组数字在Sheet2上,两组的行数和列数相同)。
因为我不知道有多少行或列,所以我要使用变量。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | 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 |
当我试图运行这个函数时,我在
谢谢您,
杰西·斯莫赫蒙
实际上,我不会使用任何redim,也不会使用循环将数据从工作表传输到数组:
1 2 | dim arOne() arOne = range("A2:F1000") |
甚至
1 | arOne = range("A2").CurrentRegion |
就是这样,你的数组被一个循环填充得更快,没有redim。
您需要
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | 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 |
正如其他人所指出的,您的实际问题将更好地用范围来解决。你可以尝试这样的方法:
1 2 3 4 5 6 7 8 9 10 11 12 13 | 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数组到范围函数,它在一次"命中"中向工作表写入一个数组。这比将数据以行和列循环的形式一次一个单元格写入工作表快得多…但是,有一些内务管理需要做,因为您必须正确地指定目标范围的大小。
这种"内务管理"看起来需要很多工作,而且可能相当慢:但这是要写入工作表的"最后一英里"代码,而且所有的工作都比写入工作表快。或者,与工作表的读或写(甚至是vba)相比,它的速度快得多,实际上是即时的,而且在点击工作表之前,您应该尽可能在代码中完成所有可能的工作。
其中的一个主要组成部分是错误捕获,我以前看到它无处不在。我讨厌重复编码:我已经在这里全部编码了,希望你再也不用写了。
"数组到范围"函数
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | 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 |
您将需要数组维度的源:
此API声明在模块头中是必需的:
1 2 3 4 | Private Declare Sub CopyMemory Lib"kernel32" Alias"RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As Long) |
…这是函数本身:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | 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 |
另外:我建议你保密申报。如果必须在另一个模块中使其成为公共子模块,请在模块头中插入
对于本例,您需要创建自己的类型,即数组。然后创建一个更大的数组,其中的元素是您刚刚创建的类型。
要运行我的示例,您需要用一些值填充Sheet1中的A列和B列。然后运行test()。它将读取前两行并将值添加到bigarr。然后,它将检查您拥有多少行数据,并从停止读取的位置(即第三行)读取所有数据。
在Excel2007中测试。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | 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 |