Visual Basic For Applications " subscript out of range" error - excel

Question

" I am getting a subscript out of range error after adding two new elements to an array. I remove the elements and re-run the code and it works. I need to know where to change the range so that it accommodates the array elements. This is the edited code: products = Array("BALANCER", "SKIN LIGHTENER", "FIRM AND FADE 6%", "FIRM AND FADE 8%")
After adding the two additional elements the error is thrown.
Research is showing that the array is the issue however after making adjustments the error message is still being thrown. "
"Here is the original code:"
Public Sub Dermesse_Dashboard(SD As Date, ED As Date)
Dim cn As ADODB.Connection
Dim rs As ADODB.RecordSet
Dim com As ADODB.Command
Dim ConnectionString As String, StoredProcName As String
Dim StartDate As ADODB.Parameter, EndDate As ADODB.Parameter, Product As ADODB.Parameter
Dim excelrange As String
Dim DateRange As String
Dim RCount As Integer
Dim products As Variant
products = Array("BALANCER", "SKIN LIGHTENER")
Set cn = New ADODB.Connection
Set rs = New ADODB.RecordSet
Set com = New ADODB.Command
Workbooks.Open ("\\apfssvr01\Arrow_RX\Reports\Templates\Dermesse_Dashboard(Template).xlsx")
ConnectionString = "Provider=sqloledb;Data Source=ARWSQL01;initial catalog=futurefill;User Id=endicia;Pwd=endicia;trusted_connection=yes;"
On Error GoTo CloseConnection
Application.ScreenUpdating = False
cn.Open ConnectionString
cn.CursorLocation = adUseClient
StoredProcName = "Dermesse_Shipped_by_Product"
With com
.ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = StoredProcName
End With
Set StartDate = com.CreateParameter("#StartDate", adDBTimeStamp, adParamInput, , SD)
com.Parameters.Append StartDate
Set EndDate = com.CreateParameter("#Enddate", adDBTimeStamp, adParamInput, , ED)
com.Parameters.Append EndDate
ActiveWorkbook.Sheets(2).Select
'loop through each item in products.
For Each i In products
'remove the product parameter if it exists so we can set it to the next product
If Product Is Nothing = False Then
com.Parameters.Delete (2)
End If
Set Product = com.CreateParameter("#Product", adVarChar, adParamInput, 200, i)
com.Parameters.Append Product
Set rs = com.Execute
'add rows to the excel table if the record set if 2 or greater.
'if we dont any tables below the first could be over written
If rs.RecordCount >= 2 Then
For j = 0 To rs.RecordCount - 3
ActiveSheet.ListObjects("Ship " & i).ListRows.Add (2)
Next
End If
ActiveSheet.ListObjects("Ship " & i).DataBodyRange.Select
Selection.CopyFromRecordset rs
rs.Close
Next
ActiveWorkbook.Sheets(6).Select
StoredProcName = "Dermesse_Shipped_wOrder"
With com
.ActiveConnection = cn
.CommandType = adCmdStoredProc
.CommandText = StoredProcName
End With
If Product Is Nothing = False Then
com.Parameters.Delete (2)
End If
Set Product = com.CreateParameter("#Product", adVarChar, adParamInput, 200, "Dermesse")
com.Parameters.Append Product
Set rs = com.Execute
RCount = rs.RecordCount
With ActiveSheet.ListObjects("Invoice DERMESSE")
If rs.RecordCount >= 2 Then
For j = 0 To rs.RecordCount - 3
.ListRows.Add (2)
Next
End If
.DataBodyRange.Select
Selection.CopyFromRecordset rs
.ListColumns(12).Range.Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(#_)"
End With
rs.Close
cn.Close
'set a data fee value for each record. look at the order number of a specific line. if the line above or below are the same
'the data fee is 7.5 else is 10
r = 9
For i = 0 To RCount - 1
If ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) - 1).Value Then
ActiveSheet.Cells(r + i, 12).Value = 7.5
ElseIf ActiveSheet.Range("C" & r + i).Value = ActiveSheet.Range("C" & (r + i) + 1).Value Then
ActiveSheet.Cells(r + i, 12).Value = 7.5
Else
ActiveSheet.Cells(r + i, 12).Value = 10
End If
Next i
If SD <> ED Then
DateRange = Format(SD, "yyyy-mm-dd") & " through " & Format(ED, "yyyy-mm-dd")
Else
DateRange = Format(SD, "yyyy-mm-dd")
End If
With ActiveWorkbook
For i = 1 To .Sheets.Count
.Sheets(i).Select
.Sheets(i).Range("A2").Value = DateRange
Next
.Sheets("Dermesse Dashboard").Select
End With
On Error GoTo 0
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ("\\apfssvr01\Arrow_RX\Reports\Dermesse\DERMESSE_Dashboard(" & DateRange & ").xlsx"), FileFormat:=51
Application.DisplayAlerts = True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
frmSwitchboard.lblDD.Caption = "Report Complete"
Exit Sub
CloseConnection:
Application.ScreenUpdating = True
frmSwitchboard.lblDD.Caption = "Error: " & Error
cn.Close
If ActiveWorkbook.Sheets(1).Name <> "Sheet1" Then
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End If
End Sub
Any help would be greatly appreciated