Results 1 to 2 of 2

Thread: Run-time error 457

  1. #1
    VBAX Regular
    Sep 2011

    Run-time error 457

    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:[vba]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:
    [vba]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") & "'")

    NAMEDDB.executeSQL sSQL

    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

    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.

  2. #2
    VBAX Master Aflatoon's Avatar
    Sep 2009
    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.
    Be as you wish to seem

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts