调整二维数组抛出types不匹配
当我偶然发现这个有用的问题和答案时，我正在解决另一个问题 。 然而，实现Control Freak给出的答案在那里退出函数并返回到我的代码上： Years = ReDimPreserve(Years, i, 3)会引发Type Mismatch错误。 我不是一个熟练的程序员来弄清楚这里发生了什么问题，所以任何人都可以从中看出这一点。
这是我的代码：
Sub DevideData() Dim i As Integer Dim Years() As String ReDim Years(1, 3) Years(1, 1) = Cells(2, 1).Value Years(1, 2) = 2 i = 2 ThisWorkbook.Worksheets("Simple Boundary").Activate TotalRows = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp).row For row = 3 To TotalRows Years = ReDimPreserve(Years, i, 3) If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then Years(i - 1, 3) = row - 1 Years(i, 1) = Cells(row, 1).Value Years(i, 2) = row i = i + 1 End If Next row End Sub
这里是由控制怪胎写的function：
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound) ReDimPreserve = False 'check if its in array first If IsArray(aArrayToPreserve) Then 'create new array ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound) 'get old lBound/uBound nOldFirstUBound = UBound(aArrayToPreserve, 1) nOldLastUBound = UBound(aArrayToPreserve, 2) 'loop through first For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound 'if its in range, then append to new array the same way If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast) End If Next Next 'return the array redimmed If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray End If End Function
我答应了一个更完整的答案。 对不起，它比我预期的晚：
- 我被另一个问题困扰了，
- 我期望推荐的技术1没有像我期望的那样工作，所以我增加了一些更令人满意的技术。
正如我在第一条评论中所说：
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)
导致aArrayToPreserve具有Variant的默认types。 这不符合：
Dim Years() As String
正如你所发现的，重新定义年份作为一个变种，解决了问题。 另一种方法是修改ReDimPreserve的声明，这样aArrayToPreserve是一个Stringtypes的数组。 我不会推荐这种方法，因为你在数组中存储string和数字。 Variant数组将处理string或数字，而String数组只能将数字转换为string进行存储并返回数字进行处理。
我用不同数量的数据和不同的修正来试用你的macros，并定时运行：
Rows of data Amendment Duration of run 3,500 Years() changed to Variant 4.99 seconds 35,000 Years() changed to Variant 502 seconds 35,000 aArrayToPreserve changed to String 656 seconds
正如我在第二个评论中所说的那样， ReDim Preserve的内置方法和你发现的VBA例程都很慢。 对于每个呼叫它必须：
- find新的更大arrays的空间
- 将旧数组中的数据复制到新数组中
- 释放旧数组进行垃圾回收。
ReDim Preserve是一个非常有用的方法，但必须非常小心使用。 有时候我发现在开始的时候最大化一个数组的尺寸，并且使用ReDim Preserve在最后将数组剪裁成所使用的大小是一个更好的技术。 下面显示的最佳技术决定了调整数组大小之前所需的条目数。
在日常工作中，我补充道：
For i = LBound(Years, 1) To LBound(Years, 1) + 9 Debug.Print Years(i, 0) & "|" & Years(i, 1) & "|" & Years(i, 2) & "|" & Years(i, 3) Next For i = UBound(Years, 1) - 9 To UBound(Years, 1) Debug.Print Years(i, 0) & "|" & Years(i, 1) & "|" & Years(i, 2) & "|" & Years(i, 3) Next
这导致以下内容被输出到即时窗口：
|AAAA|2|2 |AAAB|3|4 |AAAC|5|7 |AAAD|8|11 |AAAE|12|16 |AAAF|17|22 |AAAG|23|23 |AAAH|24|25 |AAAI|26|28 |AOUJ|34973|34976 |AOUK|34977|34981 |AOUL|34982|34987 |AOUM|34988|34988 |AOUN|34989|34990 |AOUO|34991|34993 |AOUP|34994|34997 |AOUQ|34998|35002 |AOUR|35003|
既然你叫数组Years ，我怀疑我的string值是像你的东西。 这没关系。 重要的是，我怀疑这个输出正是你想要的。
如果你写：
ReDim Years(1, 3)
下限设置为由Option Base语句指定的值，如果没有Option Base语句，则设置为零。 你有两个维度的下限，你不使用。 这是“
”顶部的原因。 最后还有一个“
”，意味着你正在创build一个你不使用的最后一行。 最后使用的行没有我假设的错误结束行。
当我能把一个例程分成几个步骤时，我总是先validation一个步骤的结果，然后才能进入下一个步骤。 这样，我知道任何问题都在目前的步骤，而不是在前面的步骤中的错误的结果。 我大多数时候使用Debug.Print输出到立即窗口。 只有当我想输出很多诊断信息时，我才会写入一个文本文件。 无论哪种方式，像我这样的代码块是一个macros的快速debugging的重要帮助。
我永远不会写ReDim Years(1, 3) 。 我总是指定下限，以便绝对清楚。 VBA是我知道的唯一的语言，你可以为下限指定任何值（假设它小于上限），所以如果对特定问题有帮助，我将指定非标准值。 在这种情况下，除了一个以外，我看不到一个下限，这是我所使用的。
对于二维数组，传统上将列作为第一维，将行作为第二维。 一个例外是数组读取或写入工作表，其维度是相反的。 你有行作为第一维。 如果您已经使用了常规序列，则可以使用ReDim Preserve方法，从而避免了RedimPreserve函数以及不匹配types的问题。
技术1
我预计这是最快的技术。 专家build议我们避免“重新发明轮子”。 也就是说，如果Excel有一个可以做你想做的例程，不要在VBA中编写一个替代scheme。 然而，我发现了一些不正确的例子，我发现这个技术就是其中之一。
这里显而易见的技术是使用Filter ，然后使用SpecialCells创build一系列可见的行，最后处理这个范围中的每一行。 我已经非常成功地使用这种技术来满足其他要求，但不是在这里。
我不知道VBAselect独特的行，所以启动macroslogging器，并从键盘过滤我的testing数据得到：
Range("A1:A35000").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
我过去的使用Filter都转换为自动Filter ，我发现给予可以接受的性能。 这转换为AdvancedFilter从键盘和从VBA花了20秒。 我不知道为什么这么慢。
第二个问题是：
Set RngUnique = .Range(.Cells(1, 1), .Cells(RowLast, 1)) _ .SpecialCells(xlCellTypeVisible)
被拒绝为“太复杂”。
无法将可见的行作为范围，意味着Filter的好处不是真正可用的。 我已经数过可见的行来模拟RngUnique.Rows.Count 。 这显示了一直使用AutoFilter 。 如果AdvancedFilter在接受的时间内报告了独特的行，我可能会调查这个问题，但在这种情况下，这似乎不值得。
展示这种技术的macros是：
Option Explicit Sub Technique1() ' * Avoid using meaningless names like i. Giving every variable a meaningful ' name is helpful during development and even more helpful when you return ' to the macro in six months for maintenence. ' * My naming convention is use a sequence of keywords. The first keyword ' identifies what type of data the variable holds. So "Row" means it holds ' a row number. Each subsequent keyword narrows the scope. "RowSb" is a ' row of the worksheet "Simple Boundary" and "RowYears" is a row of the Years ' array. "RowSbCrnt"is the current row of the worksheet "Simple Boundary". ' * I can look at macros I wrote years ago and know what all the variables are. ' You may not like my convention. Fine, development your own but do not ' try programming with random names. ' * Avoid data type Integer which specifies a 16-bit whole number and requires ' special processing on 32 and 64-bit computers. Long is now the recommended ' data type for whole numbers. Dim NumRowsVisible As Long Dim RowSbCrnt As Long Dim RowSbLast As Long Dim RowYearsCrnt As Long Dim TimeStart As Double Dim Years() As Variant TimeStart = Timer ' Get the time as seconds since midnight to nearest .001 ' of a second ' This can save significant amounts of time if the macro amends the ' screen or switches between workbooks. Application.ScreenUpdating = False With Worksheets("Simple Boundary") ' Rows.Count avoiding having to guess how many rows will be used RowSbLast = .Cells(Rows.Count, "A").End(xlUp).Row ' Hide non-unique rows With .Range(.Cells(1, 1), .Cells(RowSbLast, 1)) .AdvancedFilter Action:=xlFilterInPlace, Unique:=True End With ' Count number of unique rows. ' It is difficult to time small pieces of code because OS routines ' can execute at any time. However, this count takes less than .5 ' of a second with 35,000 rows. NumRowsVisible = 0 For RowSbCrnt = 2 To RowSbLast If Not .Rows(RowSbCrnt).Hidden Then NumRowsVisible = NumRowsVisible + 1 End If Next ' Use count to ReDim array to final size. ReDim Years(1 To 3, 1 To NumRowsVisible) RowYearsCrnt = 1 Years(1, RowYearsCrnt) = .Cells(2, 1).Value Years(2, RowYearsCrnt) = 2 For RowSbCrnt = 3 To RowSbLast If Not .Rows(RowSbCrnt).Hidden Then Years(3, RowYearsCrnt) = RowSbCrnt - 1 RowYearsCrnt = RowYearsCrnt + 1 Years(1, RowYearsCrnt) = .Cells(RowSbCrnt, 1).Value Years(2, RowYearsCrnt) = RowSbCrnt End If Next ' Record final row for final string Years(3, RowYearsCrnt) = RowSbLast .ShowAllData ' Clear AdvancedFilter End With Application.ScreenUpdating = True Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000") ' Output diagnostics For RowYearsCrnt = 1 To 9 Debug.Print Years(1, RowYearsCrnt) & "|" & _ Years(2, RowYearsCrnt) & "|" & _ Years(3, RowYearsCrnt) & "|" Next ' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2) For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2) Debug.Print Years(1, RowYearsCrnt) & "|" & _ Years(2, RowYearsCrnt) & "|" & _ Years(3, RowYearsCrnt) & "|" Next End Sub
立即窗口的输出是：
Duration: 20.570 AAAA|2|2| AAAB|3|4| AAAC|5|7| AAAD|8|11| AAAE|12|16| AAAF|17|22| AAAG|23|23| AAAH|24|25| AAAI|26|28| AOUI|34970|34972| AOUJ|34973|34976| AOUK|34977|34981| AOUL|34982|34987| AOUM|34988|34988| AOUN|34989|34990| AOUO|34991|34993| AOUP|34994|34997| AOUQ|34998|35002| AOUR|35003|35008|
正如你所看到的最后一行是正确的。 20秒的持续时间比你的技术的8分钟更好，但我相信我们可以做得更好。
技术2
下一个macros与最后一个macros类似，但它计算唯一的行，而不是使用AdvancedFilter来隐藏非唯一的行。 这个macros的持续时间为1.5秒，有35,000行。 这表明在数据的第一遍中计算数组需要多less行是一个可行的方法。 该macros的诊断输出与上述相同。
Sub Technique2() Dim NumRowsUnique As Long Dim RowSbCrnt As Long Dim RowSbLast As Long Dim RowYearsCrnt As Long Dim TimeStart As Double Dim Years() As Variant TimeStart = Timer ' Get the time as seconds since midnight to nearest .001 ' of a second With Worksheets("Simple Boundary") RowSbLast = .Cells(Rows.Count, "A").End(xlUp).Row ' Count number of unique rows. ' Assume all data rows are unique until find otherwise NumRowsUnique = RowSbLast - 1 For RowSbCrnt = 3 To RowSbLast If .Cells(RowSbCrnt, 1).Value = .Cells(RowSbCrnt - 1, 1).Value Then NumRowsUnique = NumRowsUnique - 1 End If Next ' * Use count to ReDim array to final size. ' * Note that I have defined the columns as the first dimension and rows ' as the second dimension to match convention. Had I wished, this would ' have allowed me to use the standard ReDim Preserve which can only ' adjust the last dimension. However, this does not match the ' syntax of Cells which has the row first. It may have been better to ' maintain your sequence so the two sequences were the same. ReDim Years(1 To 3, 1 To NumRowsUnique) RowYearsCrnt = 1 Years(1, RowYearsCrnt) = .Cells(2, 1).Value Years(2, RowYearsCrnt) = 2 For RowSbCrnt = 3 To RowSbLast If .Cells(RowSbCrnt, 1).Value <> .Cells(RowSbCrnt - 1, 1).Value Then Years(3, RowYearsCrnt) = RowSbCrnt - 1 RowYearsCrnt = RowYearsCrnt + 1 Years(1, RowYearsCrnt) = .Cells(RowSbCrnt, 1).Value Years(2, RowYearsCrnt) = RowSbCrnt End If Next ' Record final row for final string Years(3, RowYearsCrnt) = RowSbLast End With Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000") ' Output diagnostics For RowYearsCrnt = 1 To 9 Debug.Print Years(1, RowYearsCrnt) & "|" & _ Years(2, RowYearsCrnt) & "|" & _ Years(3, RowYearsCrnt) & "|" Next ' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2) For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2) Debug.Print Years(1, RowYearsCrnt) & "|" & _ Years(2, RowYearsCrnt) & "|" & _ Years(3, RowYearsCrnt) & "|" Next End Sub
技术3
下一个macros只是从最后一个微小的变化。
首先，我已经用常量代替了用于识别工作表和数组中列号的文字，例如：
Const ColYrEnd As Long = 3
在我的命名约定ColYrEnd = Y数组保存范围结束因此：
Years(ColYrEnd, RowYearsCrnt) = RowCvCrnt - 1 instead of Years(3, RowYearsCrnt) = RowCvCrnt - 1
这对编译后的代码没有任何影响，但是使源代码更易于理解，因为您不必记住第1,2和3列。 更重要的是，如果您必须重新排列列，则更新常量是唯一需要的更改。 如果你必须search一个长整型macros，用5代替每个2作为列号（而忽略2的任何其他用途），你就会知道为什么这很重要。
其次，我用了：
ColValues = .Range(.Cells(1, ColSbYear), _ .Cells(RowSbLast, ColSbYear)).Value
将列1导入到数组中。 从工作表读取值的代码现在从这个数组中读取它们。 数组访问比工作表访问要快得多，所以这将运行时间从1.5秒减less到0.07秒。
修改后的代码是：
Sub Technique3() Const ColCvYear As Long = 1 Const ColSbYear As Long = 1 Const ColYrYear As Long = 1 Const ColYrStart As Long = 2 Const ColYrEnd As Long = 3 Const RowSbDataFirst As Long = 2 Const RowCvDataFirst As Long = 2 Dim ColValues As Variant Dim NumRowsUnique As Long Dim RowCvCrnt As Long Dim RowSbCrnt As Long Dim RowSbLast As Long Dim RowYearsCrnt As Long Dim TimeStart As Double Dim Years() As Variant TimeStart = Timer ' Get the time as seconds since midnight to nearest .001 ' of a second With Worksheets("Simple Boundary") RowSbLast = .Cells(Rows.Count, ColSbYear).End(xlUp).Row ColValues = .Range(.Cells(1, ColSbYear), _ .Cells(RowSbLast, ColSbYear)).Value ' * The above statement imports all the data from column 1 as a two dimensional ' array into a Variant. The Variant is then accessed as though it is an array. ' * The first dimension has one entry per row, the second dimension has on entry ' per column which is one in this case. Both dimensions will have a lower bound ' of one even if the first row or column loaded is not one. End With ' Count number of unique rows. ' Assume all data rows are unique until find otherwise NumRowsUnique = UBound(ColValues, 1) - 1 For RowCvCrnt = RowCvDataFirst + 1 To UBound(ColValues, 1) If ColValues(RowCvCrnt, ColCvYear) = ColValues(RowCvCrnt - 1, ColCvYear) Then NumRowsUnique = NumRowsUnique - 1 End If Next ' I mentioned earlier that I was unsure if having rows and columns in the ' convention sequence was correct. I am even less sure here where array ' ColValues has been loaded from a worksheet and the rows and columns are ' not in the conventional sequence. ReDim Years(1 To 3, 1 To NumRowsUnique) RowYearsCrnt = 1 Years(ColYrYear, RowYearsCrnt) = ColValues(RowCvDataFirst, ColCvYear) Years(ColYrStart, RowYearsCrnt) = RowCvDataFirst For RowCvCrnt = RowCvDataFirst + 1 To UBound(ColValues, 1) If ColValues(RowCvCrnt, ColCvYear) <> ColValues(RowCvCrnt - 1, ColCvYear) Then Years(ColYrEnd, RowYearsCrnt) = RowCvCrnt - 1 RowYearsCrnt = RowYearsCrnt + 1 Years(ColYrYear, RowYearsCrnt) = ColValues(RowCvCrnt, ColCvYear) Years(ColYrStart, RowYearsCrnt) = RowCvCrnt End If Next ' Record final row for final string Years(ColYrEnd, RowYearsCrnt) = UBound(ColValues, 1) Debug.Print "Duration: " & Format(Timer - TimeStart, "#,##0.000") ' Output diagnostics For RowYearsCrnt = 1 To 9 Debug.Print Years(ColYrYear, RowYearsCrnt) & "|" & _ Years(ColYrStart, RowYearsCrnt) & "|" & _ Years(ColYrEnd, RowYearsCrnt) & "|" Next ' Note that rows are now in the second dimension hence the 2 in UBound(Years, 2) For RowYearsCrnt = UBound(Years, 2) - 9 To UBound(Years, 2) Debug.Print Years(ColYrYear, RowYearsCrnt) & "|" & _ Years(ColYrStart, RowYearsCrnt) & "|" & _ Years(ColYrEnd, RowYearsCrnt) & "|" Next End Sub
其他技术
我考虑引进其他技术，但我决定他们没有这个要求是有用的。 而且，这个答案已经够长了。 我为你提供了很多想法，更多的会超负荷。 如上所述，我已经将35,000行的运行时间从8分钟减less到20秒到1.5秒到0.07秒。
通过我的macros慢慢地工作。 我希望我已经提供了足够的解释，说明每个人在做什么。 一旦你知道存在一个陈述，通常很容易查找它，所以没有太多的陈述的解释。 根据需要回来提问。
如前所述，在处理大型数据集时，ReDim Preserve是一个昂贵的通话，一般都要避免。 以下是一些应该根据需要执行的注释代码。 在200,000行数据集上testing，花费不到5秒钟即可完成。 在1000行数据集上testing，完成时间less于0.1秒。
代码使用Collection从A列中获取唯一值，然后根据这些唯一值构build数组，然后将结果输出到另一个表。 在你原来的代码中，没有任何结果数组被输出，所以我只是做了一些事情，你需要根据需要调整输出部分。
Sub tgr() Dim ws As Worksheet Dim rngYears As Range Dim collUnqYears As Collection Dim varYear As Variant Dim arrAllYears() As Variant Dim arrYearsData() As Variant Dim YearsDataIndex As Long Set ws = ActiveWorkbook.Sheets("Simple Boundary") Set rngYears = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp)) If rngYears.Cells.Count < 2 Then Exit Sub 'No data Set collUnqYears = New Collection With rngYears .CurrentRegion.Sort rngYears, xlAscending, Header:=xlYes 'Sort data by year in column A arrAllYears = .Offset(1).Resize(.Rows.Count - 1).Value 'Put list of years in array for faster calculation 'Get count of unique years by entering them into a collection (forces uniqueness) For Each varYear In arrAllYears On Error Resume Next collUnqYears.Add CStr(varYear), CStr(varYear) On Error GoTo 0 Next varYear 'Ssize the arrYearsData array appropriately ReDim arrYearsData(1 To collUnqYears.Count, 1 To 3) 'arrYearsData column 1 = Unique Year value 'arrYearsData column 2 = Start row for the year 'arrYearsData column 3 = End row for the year 'Loop through unique values and populate the arrYearsData array with desired information For Each varYear In collUnqYears YearsDataIndex = YearsDataIndex + 1 arrYearsData(YearsDataIndex, 1) = varYear 'Unique year arrYearsData(YearsDataIndex, 2) = .Find(varYear, .Cells(1), , , , xlNext).Row 'Start Row arrYearsData(YearsDataIndex, 3) = .Find(varYear, .Cells(1), , , , xlPrevious).Row 'End Row Next varYear End With 'Here is where you would output your results 'Your original code did not output results anywhere, so adjust sheet and start cell as necessary With Sheets("Sheet2") .UsedRange.Offset(1).ClearContents 'Clear previous result data .Range("A2").Resize(UBound(arrYearsData, 1), UBound(arrYearsData, 2)).Value = arrYearsData .Select 'This will show the output sheet so you can see the results End With End Sub
正如你在评论中提到的，如果你要继续这样的话，你肯定需要在if语句中移动这个redim：
If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then Years = ReDimPreserve(Years, i, 3) Years(i - 1, 3) = row - 1 Years(i, 1) = Cells(row, 1).Value Years(i, 2) = row i = i + 1 End If
我认为这个调整multidimensional array对你来说是矫枉过正的。 我有几个build议：
范围
我注意到，你使用2个值来表示范围的开始和范围的结束（年（i，2）是开始，年（i，3）是结束）。 相反，为什么不只是使用实际的范围？
创build一个名为startNode的范围variables，当你发现范围的结尾时，用Range(startNode,endNode)创build一个Range对象。
你的代码看起来像这样：
Sub DevideData() Dim firstCell As Range Dim nextRange As Range Set firstCell = Cells(2,1) ThisWorkbook.Worksheets("Simple Boundary").Activate TotalRows = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp).row For row = 3 To TotalRows If Not Cells(row, 1).Value = Cells(row - 1, 1).Value Then Set nextRange = Range(firstCell, Cells(row-1,1)) Set firstCell = Cells(row,1) End If Next row End Sub
1Darrays
现在你不需要存储3个值！ 只是一系列的范围，你可以像这样redim：
Dim years() As Range 'Do Stuff' ReDim Preserve years(1 to i) set years(i) = nextRange i = i + 1
请注意，创buildReDimPreserve的唯一原因是，您可以同时更改二维数组的两个维度（通常只能更改第二个维度）。 使用一维数组，您可以自由地重做而不会有任何麻烦！ 🙂
为每个循环
最后，我build议你使用for each循环，而不是一个普通的循环。 它使你的循环更加明确，使你的代码更具可读性。
Dim firstCell as Range Dim lastUniqueValue as Variant Dim lastCell as Range Dim iCell as Range Set firstCell = Cells(3,1) lastUniqueValue = firstCell.Value Set lastCell = ThisWorkbook.Worksheets("Simple Boundary").Range("A100000").End(xlUp) For Each iCell in Range(firstCell, lastCell) If iCell.Value <> lastUniqueValue Then lastUniqueValue = iCell.Value 'Do Stuff End If Next
希望这可以帮助！ 🙂