简体   繁体   English

VBA-下标超出范围错误

[英]VBA - Subscript out of range error

I'm stock in this code, Subscript out of range error i think it's because the number is too big (LBound(DataArr, 20) ? 我在这段代码中有存货,下标超出范围错误,我认为这是因为数量太大(LBound(DataArr, 20)

 For i = LBound(DataArr, 20) To UBound(DataArr, 20) 'change 1->2
        DataArr(i, 86) = "" 'change 3->4 '86
    Next i

For i = LBound(DataArr, 20) To UBound(DataArr, 20) 'change 1->2 对于i = LBound(DataArr,20)到UBound(DataArr,20)'更改1-> 2

Above is my line error if i used LBound(DataArr, 20) Subscript out of range error but if i use LBound(DataArr, 1) or 2 or 3 it's working.. but the column i'm going to count is in Column T = 20 is there any other way? 如果我使用LBound(DataArr, 20) 标超出范围错误,但是如果我使用LBound(DataArr, 1)或2或3,则上面的行错误是我的行..但我要计数的Column T = 20Column T = 20还有其他方法吗?

My Full Code:(edited) 我的完整代码:(已编辑)

Public Sub Selection()

Dim file2 As Excel.Workbook
Dim Sheet2 As Worksheet, data(), i&
Dim myRangeColor As Variant, myRangeMonthValue
Dim MstrSht As Worksheet
Dim DataArr As Variant
Dim ColorArr As Variant
Dim MonthCol As Collection
Dim CloseToDate As Date
Dim MaxDate As Date
Dim c As Long


Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
Set Sheet5 = Workbooks.Open(TextBox5.Text).Sheets(1)


DataArr = Sheet2.Range("A2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) 'change 1->2

'Find distinct colors
ColorArr = ReturnDistinct(Sheet2.Range("T2:T" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)) 'change a->b 1->2

'Remove any values in the arrays third column
For i = LBound(DataArr, 1) To UBound(DataArr, 1) 'change 1->2
    DataArr(i, 86) = "" 'change 3->4 '86
Next i

'Loop Each Color
For c = LBound(ColorArr) To UBound(ColorArr)
    Set MonthCol = New Collection
    MaxDate = 0
    For i = LBound(DataArr, 1) To UBound(DataArr, 1) 'change 1->2
        If DataArr(i, 1) = ColorArr(c) Then 'change 1->2
            'Load the colors months into a collection
            On Error Resume Next
            MonthCol.Add Month(DataArr(i, 71)), CStr(Month(DataArr(i, 71))) 'change 2->3
            On Error GoTo 0
            'Find Max Date
            If DataArr(i, 71) Then 'change 2->3
                MaxDate = Application.WorksheetFunction.Max(MaxDate, DataArr(i, 71)) 'change 2->3
            End If
        End If
    Next i

    'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
    If MonthCol.Count > 2 Then
        For i = LBound(DataArr, 1) To UBound(DataArr, 1) 'change 1->2
            If DataArr(i, 1) = ColorArr(c) And DataArr(i, 71) = MaxDate Then 'change 1->2 2->3
                DataArr(i, 86) = "1" '86
                DataArr(i, 87) = "1" '87
            End If
        Next i
    End If
Next c

'Print results to sheet
Sheet2.Range("A2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr 'change 1->2

Function ReturnDistinct(InpRng As Range) As Variant
    Dim Cell As Range
    Dim i As Integer
    Dim DistCol As New Collection
    Dim DistArr()

    'Add all values to collection
    For Each Cell In InpRng
        On Error Resume Next
        DistCol.Add Cell.Value, CStr(Cell.Value)
        On Error GoTo 0
    Next Cell

    'Write collection to array
    ReDim DistArr(1 To DistCol.Count)
    For i = 1 To DistCol.Count Step 1
        DistArr(i) = DistCol.Item(i)
    Next i

    ReturnDistinct = DistArr
End Function

For i = LBound(DataArr, 20) To UBound(DataArr, 20) 'change 1->2 对于i = LBound(DataArr,20)到UBound(DataArr,20)'更改1-> 2

You are asking Excel, "what is the lower and upper bound for the 20th rank in DataArr?" 您在问Excel,“ DataArr中第20位的上下限是什么?”

The problem is -- and the reason for the subscript out of range error -- that there is no 20th rank in DataArr. 问题是-下标超出范围错误的原因-DataArr中没有第20位。 DataArr does in fact only contain 2 ranks. 实际上,DataArr仅包含2个等级。 Which means that the LBound and UBound expressions raise errors, since they are being called with invalid arguments. 这意味着LBound和UBound表达式会引发错误,因为它们使用无效的参数进行了调用。

I am not exactly sure what rank you need to access, but the 20 is what you have to change - and the way your array is set up right now, that number must be either 1 or 2. 我不确定您需要访问的等级,但是您必须更改20等级-以及现在设置数组的方式,该数字必须为1或2。

EDIT: For your leisure, here is a quick utility written by Chip Pearson that lets you programmatically verify the number of ranks in an array: 编辑:为了您的休闲,这是Chip Pearson编写的快速实用程序,可让您以编程方式验证数组中的行数:

Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
    Do
        Ndx = Ndx + 1
        Res = UBound(arr, Ndx)
    Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function

EDIT as per your comment: 根据您的评论进行编辑:

i want to count the data from column T that way i change it from 1 -> 20 我想以这种方式将T列中的数据计数为1-> 20

I am not 100% on what you mean by this, but to access data from column T in the array (column number 20), this is the syntax: 我不是100%的意思,但是要访问数组T列(第20列)中的数据,语法如下:

someValue = DataArr(i, 20)

where i is (row number - 1) in this case. 在这种情况下, i在哪里(行号-1)。

For example, DataArr(1, 20) would contain the data from Range("T2") (or Cells(2, 20) ) 例如, DataArr(1, 20)将包含Range("T2") (或Cells(2, 20) DataArr(1, 20)中的数据

EDIT as per your comments: 根据您的评论进行编辑:

this is what i'm trying but insted of columA it's columnT.. My logic 这就是我想要但insted的columA的是columnT .. 我的逻辑

same result, but now i'm going to change the column instead of A it's Column T and instead of B im comparing it with Column BS 结果相同,但现在我将更改列而不是A,而是列T,而不是B im将其与列BS进行比较

Change 更改

For i = LBound(DataArr, 20) To UBound(DataArr, 20) 'change 1->2

to

For i = LBound(DataArr, 1) To UBound(DataArr, 1) 'change 1->2

Because: 因为:

The first rank is your rows, the second rank is your columns. 第一个等级是您的行,第二个等级是您的列。 There's no 20th rank as previously discussed. 如前所述,没有第20位。 Going by your description, it sounds like you need to set every cell inside column number 86 (which I guess is "BS") to nothing. 按照您的描述,听起来您需要将第86列(我想是“ BS”)中的每个单元格都设置为空。 In this case, the above change is correct. 在这种情况下,上述更改是正确的。

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM