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
' REMEMBER TO ADD 1 to i BECAUSE IT IS OFFSET BY 1
clDataCollection.Item(i + 1).IsSelected = True
End If
Next
clNewOrders.AddSelectedNewOrdersToSchedule
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
Else
' 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
Me.lstNewOrders.Clear
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
Next
End Sub
[/vba]
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
Private NAMEDDB As NAMEDSQL
' 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
colScheduleData.RemoveAll
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
colScheduleData.RemoveAll
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.OpenConnection
NAMEDDB.executeSQL sSQL
Set getNewOrders = processRecordSetForNewOrders(SchrothDB)
NAMEDDB.CloseConnection
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
rs.MoveNext
Loop
rs.Close
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
Else
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
Next
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
Next
' 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/que...a_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
Close
' 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)
Close
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
[/vba]
If anything is unclear, I have more code I can paste in for anything that may not be defined.
Reply With Quote
