如何dynamic调整VBA中的数组的大小？ 我不断收到下标和索引问题
Dim codesArray() As Variant ... If WorksheetExists(workSheetName) Then ... Else ReDim Preserve codesArray(UBound(codesArray) + 1) ' Error subscript codesArray(UBound(codesArray)) = cell.Value End If 我不知道为什么我得到一个索引超出范围的错误。
基本上每次没有find工作表名称，我想将其添加到数组，然后最终让用户知道缺less的工作表的名称。
所以最好的员工会丢失0个工作表。 最糟糕的是他们都错过了。
正如已经说过的var()会在检查时出错。 要做到这一点没有任何错误，你可以使用这样的代码：
Dim codesArray ... If WorksheetExists(workSheetName) Then ... Else If IsArray(codesArray) Then ReDim Preserve codesArray(UBound(codesArray) + 1) Else ReDim codesArray(0) End If codesArray(UBound(codesArray)) = cell.Value End If
或者像这样：
Dim codesArray ... If WorksheetExists(workSheetName) Then ... Else If IsArray(codesArray) Then ReDim Preserve codesArray(UBound(codesArray) + 1) codesArray(UBound(codesArray)) = cell.Value Else codesArray = Array(cell.Value) End If End If
关于这一点的好处是避免了任何错误更改代码。 所以如果出现错误的原因不同，就不会被压制。 也应该是自我解释….如果你还有任何问题，请问;）
问题是与UBound(codesArray) 。 你不能在尚未UBound()尺寸的数组上调用UBound() 。
您可以使用error handling来覆盖这种情况。 抽象为一个潜在的有用的sub：
Sub ExtendArray(A As Variant, Optional NewPlaces = 1, Optional LBase = 0) On Error GoTo err_handler ReDim Preserve A(LBound(A) To UBound(A) + NewPlaces) Exit Sub err_handler: ReDim A(LBase To LBase + NewPlaces - 1) End Sub
使用variablesk。
Dim codesArray() As Variant Dim k As Long ... If WorksheetExists(workSheetName) Then ... Else ReDim Preserve codesArray(k) ' Error subscript codesArray(k) = Cell.Value k = k + 1 End If
上面的代码arrays号从0开始。
波纹pipe代码arrays号从1开始.Lbound（codeArray）是1。
Dim codesArray() As Variant Dim k As Long ... If WorksheetExists(workSheetName) Then ... Else k = k + 1 ReDim Preserve codesArray(1 To k) ' Error subscript codesArray(k) = Cell.Value End If
使用集合而不是数组可能会更好 – 不需要resize。
Sub Test() Dim vSheetNames As Variant Dim sht As Variant Dim colMissing As Collection Dim vItem As Variant Dim sMissingString As String Dim lLastComma As Long vSheetNames = Array("Sheet1") ', "Sheet2", "Sheet3", "Sheet4", "Sheet5" 'Build a collection of missing sheets. Set colMissing = New Collection For Each sht In vSheetNames If Not WorkSheetExists(CStr(sht)) Then colMissing.Add sht End If Next sht If colMissing.Count = 0 Then MsgBox "All sheets are present", vbOKOnly + vbInformation Else 'Build the message string. For Each vItem In colMissing sMissingString = sMissingString & vItem & ", " Next vItem 'Remove the last comma. sMissingString = Left(sMissingString, Len(sMissingString) - 2) 'Replace last comma with the word 'and'. lLastComma = InStrRev(sMissingString, ",") If lLastComma > 0 Then sMissingString = Left(sMissingString, lLastComma - 1) & " and" & Mid(sMissingString, lLastComma + 1) End If MsgBox IIf(colMissing.Count = 1, "This sheet is ", "These sheets are ") & "missing: " & vbCr & _ sMissingString, vbOKOnly + vbInformation End If End Sub Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean Dim wrkSht As Worksheet If WrkBk Is Nothing Then Set WrkBk = ThisWorkbook End If On Error Resume Next Set wrkSht = WrkBk.Worksheets(SheetName) WorkSheetExists = (Err.Number = 0) Set wrkSht = Nothing On Error GoTo 0 End Function