I'm stock in this code, Subscript out of range error i think it's because the number is too big(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
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?
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
UBoundandLBoundwith1or2as the second argument for the number of rows or the number of columns (in this order). - John Alexiou