Hi,
I've been looking at this code and looking at this code. I can't find what is causing this error. (Runtime Error '9' Subscript out of range)
Essentially the script concatenates values to a cell if they meet a certain standard. Once in the cell I get the position of certain values to be colored (store them in an array). After the concatenating is finished I used the saved positions to specifically color certain characters in a cell.
The debugger complains about the line which has "For h = 0 To UBound(colorStart)" under the header
'-------------------------
' Perform coloring
'-------------------------
[VBA]Function FormatSpreadsheet()
Dim x, j, y, i, k, t, h As Long
Dim LastCol, LastRow As Long
Dim RowPos, ColPos As Long
'-------------------------------------------------------------
' Deleting columns headed with 'AE Comment'
'-------------------------------------------------------------
'Finds the last column in the Range: gives column count
LastCol = Cells.Find("*", SearchOrder:=xlByColumns, _
LookIn:=xlValues, SearchDirection:=xlPrevious).Column
'Deletes the empty columns in the Range
For j = LastCol To 5 Step -3
Columns(j).Delete
Next j
'Find the last used row in column A: gives row count
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Selects the starting cell
Range("B2").Select
'-------------------------------------------------------------
' Iterating DOWN the rows
'-------------------------------------------------------------
For x = 1 To LastRow
Dim LastColcurRow, z As Long
'color array is reset every time a new row is reached
Dim colorStart() As Long 'starting character coordinates of colored region
Dim colorEnd() As Long 'ending character coordinates of colored region
'Gets the beginning postion of the row; will have to return here before moving down a row
RowPos = ActiveCell.Row
ColPos = ActiveCell.Column
'Find the last used column in the current row
i = x + 1 'i gives the row number/position, when x = 1 (the 1st row we are working in) i = 2 (since the 1st row we are working in is actually the second)
With ActiveSheet
LastColcurRow = .Cells(i, .Columns.Count).End(xlToLeft).Column
End With
LastColcurRow = (LastColcurRow - 2) / 2 'Gets the number of times to move the selected cell right ACROSS the row, the math is needed because the nested for loop does to slides right
z = 0 'z is the iterator for the color array
'-------------------------------------------------------------
' Iterating ACROSS the rows (nested 'For' loop)
'-------------------------------------------------------------
For y = 1 To LastColcurRow
Dim rPos, cPos As Long
Dim ErPos, EcPos As Long
Dim base1, base2 As Long
Dim diffColor, strt, NNflag As Long
'slides selected cell right one position to 'allele' column
ActiveCell.Offset(0, 1).Select
'-------------------------------------------------------------
' Location: first allele cell
'-------------------------------------------------------------
'-------------------------------------------------------------
' NonNumeric Catch
'-------------------------------------------------------------
'If the first Allele cell is NOT numeric; X
If Not IsNumeric(ActiveCell.Value) And ActiveCell.Column = 3 Then
NNflag = 1 'Sets NonNumeric flag to one
Else
NNflag = 0 'Sets NonNumeric flag to zero
End If
'If the second Allele cell is NOT numeric; Y
If Not IsNumeric(ActiveCell.Value) And ActiveCell.Column = 5 Then
NNflag = 1 'Sets NonNumeric flag to one
Else
NNflag = 0 'Sets NonNumeric flag to zero
End If
'-------------------------------------------------------------
' Numeric Catch
'-------------------------------------------------------------
'stores the concatenation site
If IsNumeric(ActiveCell.Value) And ActiveCell.Column = 3 Then
rPos = ActiveCell.Row
cPos = ActiveCell.Column
End If
'-------------------------------------------------------------
' Location: Not first allele cell
'-------------------------------------------------------------
'store the sites 'to be' concatenated
If IsNumeric(ActiveCell.Value) And ActiveCell.Column <> 3 Then
ErPos = ActiveCell.Row
EcPos = ActiveCell.Column
End If
'-------------------------------------------------------------
' Slide Right to Height Column
'-------------------------------------------------------------
ActiveCell.Offset(0, 1).Select
Height = ActiveCell.Value
'--------------------------------------------------------------------------------------------
' checking data
'--------------------------------------------------------------------------------------------
'-------------------------------------------------------------
' Check NonNumerical Data
'-------------------------------------------------------------
If NNflag = 0 Then
'-------------------------------------------------------------
' Location: first height cell
'-------------------------------------------------------------
'if 1st height under 50,clear the cell
If Height < 50 And ActiveCell.Column = 4 Then
Cells(rPos, cPos).ClearContents
End If
If Height >= 50 And Height <= 99 And ActiveCell.Column = 4 Then
base1 = Len(Cells(rPos, cPos)) 'find the length of the base site
strt = 0
diffColor = base1
End If
'-------------------------------------------------------------
' Location: any height cell, but the first 50<=Height<=99
'-------------------------------------------------------------
'if the height is greater or equal to 50 but less than or equal to 99, concatenate to base site and store information
If Height >= 50 And Height <= 99 And ActiveCell.Column <> 4 Then
'if contents of base site are empty
If Cells(rPos, cPos).Value = "" Then
Cells(rPos, cPos) = Cells(ErPos, EcPos)
Else
base1 = Len(Cells(rPos, cPos)) 'find the length of the base site
Cells(rPos, cPos) = Cells(rPos, cPos) & "," & Cells(ErPos, EcPos) 'concatenate to the base site
base2 = Len(Cells(rPos, cPos)) 'find the length of the base site with the change
diffColor = base2 - base1 'the difference between the two lengths is the length of the characters just concatenated to the base site (important for coloring)
'-------------------------------------------------------------
' storing start and end postions of characters to be colored
'-------------------------------------------------------------
ReDim colorStart(z)
colorStart(z) = (base1 + 1)
z = (z + 1) 'iterate
ReDim colorEnd(z)
colorEnd(z) = diffColor
z = (z + 1) 'iterate
End If
End If
'-------------------------------------------------------------
' Location: any height cell, but the first Height>99
'-------------------------------------------------------------
'if the height is > than 99, then just concatenate to base site
If Height > 99 And ActiveCell.Column <> 4 Then
'if contents of base site are empty
If Cells(rPos, cPos).Value = "" Then
Cells(rPos, cPos) = Cells(ErPos, EcPos)
Else
Cells(rPos, cPos) = Cells(rPos, cPos) & "," & Cells(ErPos, EcPos) 'concatenate to the base site
End If
End If
Else
NNflag = 0
End If
'--------------------------------
'End of Iterating ACROSS the rows
'--------------------------------
'--------------------------------
'Perform coloring
'--------------------------------
'checking if array has any contents
If IsEmpty(colorStart) Then
MsgBox "Array is Empty!"
Else
For h = 0 To UBound(colorStart)
Cells(rPos, cPos).Characters(colorStart(h), colorEnd(h)).Font.Color = &HC0C0C0
Next h
End If
Next y
'Goes back the beginning of the row
Cells(RowPos, ColPos).Select
'Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
'--------------------------------
'End of Iterating DOWN the rows
'--------------------------------
Next x
'-------------------------------------------------------------
' Deleting Leftover Columns
'-------------------------------------------------------------
'Finds the last column in the Range: gives column count
Las = Cells.Find("*", SearchOrder:=xlByColumns, _
LookIn:=xlValues, SearchDirection:=xlPrevious).Column
'Deletes the left over columns
For k = 6 To Las
Columns(6).Delete
Next k
'Deletes the Extra Height Columns
Columns(4).Delete
Range("D2").Select
'Deletes All but 'Y' in second column
For t = 1 To LastRow
If IsNumeric(ActiveCell.Value) Then
ActiveCell.ClearContents
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Next t
'-------------------------------------------------------------
' Modifing Headers
'-------------------------------------------------------------
Range("C1").Select
ActiveCell.Value = "Allele Frequencies"
ActiveCell.Offset(0, 1).Select
ActiveCell.ClearContents
End Function
[/VBA]
Reply With Quote
