关于VBA：重新设置2D数组会引发类型不匹配


Redimming a 2d array throws type mismatch

当我偶然发现这个有用的问题和答案时，我正在研究另一个问题的解决方案。 但是，在那儿实现Control Freak给出的答案后，我退出该函数并返回到代码行Years = ReDimPreserve(Years, i, 3)时，立即抛出Type Mismatch错误。 我不是一个熟练的程序员来弄清楚这里出了什么问题，所以任何人都可以对此有所了解。

这是我的代码：

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
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

这是Control Freak编写的函数：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
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不能按我预期的那样工作，因此我添加了其他一些更令人满意的技术。

    • 正如我在第一条评论中所说：

    好的。

    1
    Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)

    导致aArrayToPreserve具有默认类型的Variant。这不符合：

    好的。

    1
    Dim Years() As String

    如您所见，将Years重新定义为Variant可以解决问题。另一种方法是修改ReDimPreserve的声明，使aArrayToPreserve是String类型的数组。我不推荐这种方法，因为您将字符串和数字都存储在数组中。 Variant数组将处理字符串或数字，而String数组只能通过将数字转换为字符串进行存储并返回数字进行处理来处理数字。

    好的。

    我尝试了使用不同数量的数据和不同的修订的宏，并对运行时间进行了计时：

    好的。

    1
    2
    3
    4
    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

    正如我在第二条评论中所述，对于内置方法和找到的VBA例程，ReDim Preserve都很慢。对于每个呼叫，它必须：

    好的。

  • 为新的更大阵列找到空间
  • 将数据从旧数组复制到新数组
  • 释放旧数组进??行垃圾回收。

    • 好的。

    ReDim Preserve是一种非常有用的方法，但必须格外小心。有时，我发现在开始时将数组的大小最大并使用ReDim Preserve将数组切成最后使用的大小是一种更好的技术。下面显示的最佳技术确定阵列大小之前所需的条目数。

    好的。

    在您的例程的底部，我添加了：

    好的。

    1
    2
    3
    4
    5
    6
    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

    这导致以下内容输出到立即窗口：

    好的。

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    |||
    |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，因此我怀疑我的字符串值是否与您的字符串值相同。没关系。重要的是，我怀疑此输出是否正是您想要的。

    好的。

    如果您写：

    好的。

    1
    ReDim Years(1, 3)

    下限设置为Option Base语句指定的值，如果没有Option Base语句，则设置为零。您没有使用的零个维度的下限。这就是" |||"的原因在顶部。还有另一个" |||"最后，这表示您正在创建未使用的最后一行。最后使用的行没有结尾行，我认为这是错误的。

    好的。

    当我可以将一个例程划分为多个步骤时，我总是先验证一个步骤的结果，然后再进行下一个步骤。这样，我知道任何问题都在当前步骤之内，而不是先前步骤中错误的结果。我大多数时候使用Debug.Print输出到立即窗口。仅当我要输出大量诊断信息时，我才会写入文本文件。无论哪种方式，像我的代码块都可以帮助快速调试宏。

    好的。

    我永远不会写ReDim Years(1, 3)。我总是指定下限，以便绝对清楚。 VBA是我知道的唯一一种语言，您可以在其中指定下限的任何值(前提是该值小于上限)，因此如果对特定问题有所帮助，我将指定非标准值。在这种情况下，我认为除了下限以外没有优势，这就是我所使用的。

    好的。

    对于二维数组，通常将列作为第一维，将行作为第二维。从数组读取或写入数组的一个例外是尺寸相反的数组。您将行作为第一个维度。如果使用了常规序列，则可以使用ReDim Preserve方法，从而避免了RedimPreserve函数和类型不匹配的问题。

    好的。

    技术1

    好的。

    我希望这是最快的技术。专家建议我们避免"重新发明轮子"。也就是说，如果Excel具有可以满足您需要的例程，请不要在VBA中编写替代方法。但是，我发现了许多不正确的示例，并且我发现这种技术就是其中之一。

    好的。

    这里最明显的技术是使用Filter，然后使用SpecialCells创建一个可见行范围，最后处理该范围内的每一行。我已经非常成功地使用了此技术来满足其他要求，但这里还没有。

    好的。

    我不知道VBA会选择唯一的行，所以启动了宏记录器并从键盘过滤了我的测试数据以得到：

    好的。

    1
    Range("A1:A35000").AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    我过去对Filter的使用已全部转换为AutoFilter，我发现它可以提供可接受的性能。这转换为AdvancedFilter，从键盘和VBA花费了20秒。我不知道为什么这么慢。

    好的。

    第二个问题是：

    好的。

    1
    2
      Set RngUnique = .Range(.Cells(1, 1), .Cells(RowLast, 1)) _
                                   .SpecialCells(xlCellTypeVisible)

    被拒绝为"太复杂"。

    好的。

    无法获得可见范围的行表示Filter的优点实际上并没有提供。我已经计算了可见行以模拟具有RngUnique.Rows.Count的行。这显示了AutoFilter一直有效的技术。如果AdvancedFilter在可接受的时间内报告了唯一的行，我可能已经调查了此问题，但是在这种情况下，似乎不值得这样做。

    好的。

    演示此技术的宏是：

    好的。

    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
    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

    即时窗口的输出为：

    好的。

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    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

    好的。

    下一个宏与上一个宏相似，但是它计算唯一行，而不是使用AdvancedFilter来隐藏非唯一行。该宏的持续时间为1.5秒，包含35,000行。这表明在数据的第一遍中计算数组需要多少行是一种可行的方法。该宏的诊断输出与上面的相同。

    好的。

    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
    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

    好的。

    下一个宏仅与上一个宏略有不同。

    好的。

    首先，我用常量替换了用于标识工作表和数组中列号的文字：

    好的。

    1
      Const ColYrEnd As Long = 3

    在我的命名约定下，ColYrEnd = Year列的数组保存范围End因此：

    好的。

    1
    2
               Years(ColYrEnd, RowYearsCrnt) = RowCvCrnt - 1
    instead of Years(3, RowYearsCrnt) = RowCvCrnt - 1

    这与编译后的代码没有区别，但是使源代码更易于理解，因为您不必记住第1、2和3列的含义。更重要的是，如果您必须重新排列列，则更新常数是唯一需要的更改。如果您必须搜索一个长宏，则将每次使用2作为列号(而忽略2的其他用法)都替换为5，您将知道为什么这很重要。

    好的。

    其次，我使用了：

    好的。

    1
    2
    ColValues = .Range(.Cells(1, ColSbYear), _
                       .Cells(RowSbLast, ColSbYear)).Value

    将第1列导入数组。现在，从工作表中读取值的代码将从该数组中读取它们。数组访问比工作表访问快得多，因此可以将运行时间从1.5秒减少到.07秒。

    好的。

    修改后的代码是：

    好的。

    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
    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分钟减少到20秒，从1.5秒减少到了0.07秒。

    好的。

    通过我的宏慢慢工作。我希望我已经对每个工作进行了充分的解释。一旦知道存在一条语句，通常就很容易查找它，因此对语句的解释不太多。必要时再问一些问题。

    好的。

    好。

    相关讨论

    如前所述，ReDim Preserve是处理大型数据集时的昂贵调用，通常避免使用。这是一些应按需执行的注释代码。在具有200,000行的数据集上进行测试后，不到5秒即可完成。在具有1000行的数据集上进行测试，只需不到0.1秒即可完成。

    该代码使用Collection从A列中获取唯一值，然后根据这些唯一值构建数组并将结果输出到另一张纸。在您的原始代码中，没有结果输出的数组，因此我只是做了一些事情，您需要根据需要调整输出部分。

    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
    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：

    1
    2
    3
    4
    5
    6
    7
    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

    我认为这种重新定义多维数组的方法对您来说太过分了。我有一些建议：

    范围

    我注意到您使用2个值来表示范围的开始和范围的结束(years(i，2)是开始，而years(i，3)是结束)。相反，为什么不只使用实际范围呢？

    创建一个名为startNode的范围变量，当您找到范围的末尾时，创建一个与Range(startNode,endNode)类似的Range对象。

    您的代码将如下所示：

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    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

    一维阵列

    现在，您不需要存储3个值！您可以像这样重新排列一系列范围：

    1
    2
    3
    4
    5
    Dim years() As Range
    'Do Stuff'
    ReDim Preserve years(1 to i)
    set years(i) = nextRange
    i = i + 1

    请注意，创建ReDimPreserve的唯一原因是可以重新设置2D数组的两个维度(通常只能更改第二个维度)。借助一维阵列，您可以自由地进行重设，而不会遇到任何麻烦！ :)

    对于每个循环

    最后，我建议您使用for each循环而不是常规的for循环。它使您对循环的意图更加明确，从而使您的代码更具可读性。

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    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

    希望这可以帮助！ :)

    相关讨论