View Full Version : Run-time error 457

09-19-2011, 09:30 AM
Hi there,
I have a Form in my spreadsheet that works with a SQL Server to add information to a Worksheet.
For some reason, whenever I click on the "Get New Orders" button, I get the Run-time error 457: "This key is already associated with an element of this collection." I have been able to identify the line that it comes up on, I will indicate below.

Form Code:Option Explicit

Private clDataCollection As ScheduleDataCollection ' (SQL Query in class module)
Private clNewOrders As ScheduleNewOrders

Private Sub UserForm_Initialize()
Set clNewOrders = New ScheduleNewOrders
Me.txtFilterDateStarted.Text = VBA.Format(VBA.DateAdd("d", -10, Now()), "mm/dd/yyyy")
End Sub

Private Sub UserForm_Terminate()
Set clNewOrders = Nothing
End Sub

Private Sub cmdAddSelectedOrders_Click()
Dim i As Long

For i = 0 To Me.lstNewOrders.ListCount - 1
If (Me.lstNewOrders.Selected(i) = True) Then
' add the isSelected = True to ScheduleData
clDataCollection.Item(i + 1).IsSelected = True
End If

End Sub

Private Sub cmdGetNewOrders_Click()
' Check to see if there is a date filter added to the Userform
If (Len(Me.txtFilterDateStarted.Text) > 0) Then
' Check if it's a date
If (IsDate(Me.txtFilterDateStarted.Text) = False) Then
MsgBox "Please enter a valid date in 'Filter Date Started'.", vbExclamation, "Error"
Exit Sub
' Set date filter in NewOrders class
clNewOrders.FilterDateEnteredInFE = CDate(Me.txtFilterDateStarted.Text)
End If
End If

Set clDataCollection = clNewOrders.getNewOrders <------Error Here

If (clDataCollection.Count <= 0) Then Exit Sub

' Clear list

Dim i As Long

' Loop through data collection and add orders
lstNewOrders.ColumnCount = 2

For i = 1 To clDataCollection.Count
lstNewOrders.AddItem clDataCollection.Item(i).JobCode
lstNewOrders.List(lstNewOrders.ListCount - 1, 1) = clDataCollection.Item(i).LineNumber
End Sub

Class Module information; some values and names were replaced with comments or other values:
Option Explicit

' This class is designed to update the Production Schedule
Private Const ScheduleSheetName As String = "Production Schedule"
Private Const sSQLFolder As String = "\\PATH\SQL Queries"
Private Const sFileScheduleCopyPaste As String = Location
Private Const sReplaceDateFilter As String = "@selectDate"
Private dteFilterDateEnteredInFE As Date

Private colScheduleData As ScheduleDataCollection

' Enum for the worksheet to update the columns
Private Enum ScheduleColumns
'Long list of column names
End Enum

' Filter Date Entered in FE Property
' lets the user filter the results based on date entered in FE
Public Property Let FilterDateEnteredInFE(ByVal dte As Date)
dteFilterDateEnteredInFE = dte
End Property
Public Property Get FilterDateEnteredInFE() As Date
FilterDateEnteredInFE = dteFilterDateEnteredInFE
End Property

' Schedule Data Collection Property
Public Property Get DataCollection() As ScheduleDataCollection
Set DataCollection = colScheduleData
End Property

Private Sub Class_Initialize()
Set SchrothDB = New NAMEDSQL
Set colScheduleData = New ScheduleDataCollection

' set a standard filter date of 1 month previous
Me.FilterDateEnteredInFE = VBA.DateAdd("m", -1, Now())
End Sub

Private Sub Class_Terminate()
' clean up code
Set colScheduleData = Nothing

Set SchrothDB = Nothing
End Sub

Public Function getNewOrders() As ScheduleDataCollection
' this procedure uses the SchrothSQL database connection to get a list of orders based on a date
' to filter for the results

' if we ever need to leave the function, it will be set to nothing by default
Set getNewOrders = Nothing

' Clear collection before setting new values

Dim sSQL As String

sSQL = getTextFromFile(sSQLFolder & sFileScheduleCopyPaste)

If (VBA.Len(sSQL) <= 0) Then Exit Function

sSQL = VBA.Replace(sSQL, sReplaceDateFilter, "'" & VBA.Format(Me.FilterDateEnteredInFE, "mm/dd/yyyy") & "'")


Set getNewOrders = processRecordSetForNewOrders(SchrothDB)

End Function

Private Function processRecordSetForNewOrders(ByRef db As SchrothSQL) As ScheduleDataCollection
' loops through data and updates the ScheduleDataCollection
If (db.recordSetIsEmpty = True) Then Exit Function

Set processRecordSetForNewOrders = Nothing

Dim rs As ADODB.RecordSet
Set rs = db.RecordSet

If rs.Fields.Count > 0 Then

Do While Not rs.EOF
Dim d As ScheduleData
Set d = New ScheduleData

'Long list of SQL Query Values

colScheduleData.Add d


Set rs = Nothing
Set processRecordSetForNewOrders = colScheduleData
End If
End Function

Private Function IfIsNull(ByRef v As Variant) As String
If (IsNull(v)) Then
IfIsNull = vbNullString
IfIsNull = v
End If
End Function

Public Sub AddSelectedNewOrdersToSchedule()
' This is used to add new orders selected from user to the schedule at the very end of the data
If (SheetExists(ScheduleSheetName) = False) Then
MsgBox "Cannot find sheet '" & ScheduleSheetName & "'! Terminating program."
Exit Sub
End If

If (colScheduleData.Count <= 0) Then Exit Sub

Application.ScreenUpdating = False

Dim i As Long

For i = 1 To colScheduleData.Count
' looks for isSelected, then adds it to the schedule
If (colScheduleData.Item(i).IsSelected) Then
Call AddOrderToSchedule(colScheduleData.Item(i))
End If

Application.ScreenUpdating = True
End Sub

Private Sub AddOrderToSchedule(ByRef d As ScheduleData)
' this is used to add the order to the worksheet
Dim ScheduleSheet As Excel.Worksheet
Dim NewRow As Long
Dim cf As CellFunctions

Set cf = New CellFunctions

Set ScheduleSheet = ThisWorkbook.Worksheets(ScheduleSheetName)
NewRow = cf.getLastRowInColumn(ScheduleSheet, 1) + 1

With ScheduleSheet
'Long list of cell values
End With ' With ScheduleSheet

Call AddFormulasToSchedule(ScheduleSheet, NewRow)
End Sub

Private Sub AddFormulasToSchedule(ByRef ws As Excel.Worksheet, ByVal iRow As Long)
' using the passed Row value, this adds the necessary formulas to the schedule
' Assumes the sheet exists

' Order Total formula
ws.Cells(iRow, ScheduleColumns.OrderTotal).Formula = _
"=SUM(" _
& ws.Cells(iRow, ScheduleColumns.BeltRevenue).Address(0, 1) _
& ":" _
& ws.Cells(iRow, ScheduleColumns.PlatingRevenue).Address(0, 1) _
& ")"

' Balance Formula
ws.Cells(iRow, ScheduleColumns.Balance).Formula = _
"=" _
& ws.Cells(iRow, ScheduleColumns.InvoicedAmount).Address(0, 1) _
& "-" _
& ws.Cells(iRow, ScheduleColumns.OrderTotal).Address(0, 1)

End Sub

Private Function getDocumentationInfo(ByRef sInfo As String) As String
' processes which kind of documentation info to look for in the string
' then builds a new string to be added to the production schedule

If (Len(sInfo) <= 0) Then Exit Function

Dim searchStrings(3, 1) As String
Dim displayString As String

searchStrings(0, 0) = "VALUE"
searchStrings(0, 1) = "VALUE"
searchStrings(1, 0) = "VALUE"
searchStrings(1, 1) = "VALUE"
searchStrings(2, 0) = "VALUE"
searchStrings(2, 1) = "VALUE"
searchStrings(3, 0) = "VALUE"
searchStrings(3, 1) = "VALUE"

Dim i As Long
Dim index As Long

For i = 0 To UBound(searchStrings, 1)
index = InStr(1, sInfo, searchStrings(i, 0), vbTextCompare)
If (index > 0) Then
' check if NOT required
If (InStr(1 _
, Mid(sInfo, index, Len(searchStrings(i, 0)) + Len(" not req")) _
, "Not Req", vbTextCompare) _
<= 0) Then

displayString = displayString & searchStrings(i, 1) & Chr(10)
End If
End If

' remove last newline from string
If (Len(displayString) > 0) Then
displayString = Left(displayString, Len(displayString) - 1)
End If

getDocumentationInfo = displayString
End Function

Private Function SheetExists(ByVal wsName As String) As Boolean
' Determines if the specified sheet exists in the workbook
On Error Resume Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(wsName)
SheetExists = Not ws Is Nothing
End Function

' COURTESY OF: http://www.exceluser.com/explore/questions/vba_textcols.htm
Private Function getTextFromFile(ByRef sFile As String) As String

If (FileExists(sFile) = False) Then
getTextFromFile = vbNullString
Exit Function
End If

Dim nSourceFile As Integer

' Close any open text files

' Get the number of the next free text file
nSourceFile = FreeFile

' Write the entire file to sText
Open sFile For Input As #nSourceFile
getTextFromFile = VBA.Input$(LOF(1), 1)
End Function

Private Function FileExists(ByRef sFile As String) As Boolean
On Error Resume Next
If Not Dir(sFile, vbDirectory) = vbNullString Then
FileExists = True
Exit Function
End If
On Error GoTo 0
FileExists = False
End Function

If anything is unclear, I have more code I can paste in for anything that may not be defined.

09-19-2011, 11:14 PM
I suggest you step through the code after the initial error to work out where the true error lies (presumably when adding to a Collection somewhere). I suspect perhaps you are not using the key you think.