Vba excel ошибка 457

Dim toprow As New Dictionary, Dictkey As Variant
Dim val As String

Range("A1").Activate 
i = 0
Do Until i = ColLen
    val = Chr(65 + i)
    toprow.Add ActiveCell.value, val
    i = i + 1
    ActiveCell.Offset(0, 1).Activate
Loop

6

I am having trouble writing a macro for comparing multiple columns in multiple sheets (of same excel file). I wrote few but they were taking so long that excel was crashing.

Let’s say I have 4 sheets in one same file.
Sheet1 with two columns (B and C) and 7000 rows.
Sheet2 empty sheet new entries.
Sheet3 empty sheet for old entries but with some updated value/info.
Sheet4 is a database with 2 columns (A and B) and 22000 rows.

I need to compare Column A from Sheet1 to Column B in Sheet4.
If there are completely new entries in Column A sheet1, then copy that entry from Column A sheet1 (and its respective value from Column B sheet1) to a new row (columns A and B) in Sheet2.
If there are entries in Column A Sheet1 that are already in Column A sheet4, then compare their respective Column B values. If column A+column B combo from Sheet 1 is in Sheet4 then ignore it. If a Value from Column A Sheet1 is in Column A Sheet4, but their respective Column B values are not matching then copy Column A+Column B from Sheet1 to new row (columns A and B) in Sheet3.

I hope it is clear enough. Due to amount of rows (7000 in Sheet1 to be compared to 20000 in Sheet4) I cannot write a macro that processes everything under a minute.

Any help ?

Edit 1: I used the code suggested by @FaneDuru (Thank You!). but I am encountering an error: «Run-time error ‘457’:This key is already associated with an element of this collection»
Is it because I have many repeating values in same columns ?

Edit 2: It seems like «if not dict3.exists» code is not recognized by VBA. When I type «.exists» with smaller letter and jump to another line it is supposed correct it to capital «.Exists», right? It is not doing it.

Edit 3: I did some more testing. I was putting breaks and running the code. When I put the break on this line «If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then», no error happens. When I put the break on one line below «For j = UBound(arr4) To 1 Step -1», the error is happening.

Error is : «Run-time error ‘457’:This key is already associated with an element of this collection»

Private Sub CommandButton1_Click()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim arr1, arr2, arr3, arr4, dict2 As Object, dict3 As Object, rngA4 As Range
Dim rngB4 As Range, i As Long, j As Long, lastR1 As Long, lastR4 As Long

lastR1 = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
lastR4 = Sheet4.Range("A" & Sheet4.Rows.Count).End(xlUp).Row

Set rngA4 = Sheet4.Range("A2:A" & lastR4)
Set rngB4 = Sheet4.Range("B2:B" & lastR4)

arr1 = Sheet1.Range("B2:C" & lastR1).Value
arr4 = Sheet4.Range("A2:B" & lastR4).Value

Set dict2 = CreateObject("Scripting.Dictionary")
Set dict3 = CreateObject("Scripting.Dictionary")

For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4, arr1(i, 1)) = 0 Then
        dict2.Add arr1(i, 1), arr1(i, 2):
    End If
    If WorksheetFunction.CountIf(rngA4, arr1(i, 1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i, 1) = arr4(j, 1) Then
                If arr1(i, 2) <> arr4(j, 2) Then
                    If arr1(i, 2) <> arr4(j, 2) Then
                        dict3.Add arr1(i, 1), arr1(i, 2): Exit For
                End If
            End If
        Next j
    End If
Next i

If dict2.Count > 0 Then
    arr2 = Application.Transpose(Array(dict2.keys, dict2.Items))
    Sheet2.Range("A2").Resize(dict2.Count, 2).Value = arr2
End If

If dict3.Count > 0 Then
    arr3 = Application.Transpose(Array(dict3.keys, dict3.Items))
    Sheet3.Range("A2").Resize(dict3.Count, 2).Value = arr3
End If

MsgBox "Done!"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

I’m trying to create a dictionary of dictionary structure in vba

Basically, I start with a 3 column tables :

Product Id | Customer Id | Source

1 | 1 | A

1 | 2 | A

2 | 1 | A

3 | 1 | B

And I want to transform it into a main dictionary «DicByUser» where the keys are the user ids and the items are another dictionary that contain as keys the products visited by a client and as item the source code.

In that case, I would have

DicByUser= { 1 : { 1 : A , 2 : A, 3 : B}, 2 : {1 : A }}

My approach was to go through all the rows of my initial table then :

with Cid the customer Id,

Pid the product Id,

source the Source

If DicByUser.Exists(Cid) Then
    If DicByUser.Item(Cid).Exists(Pid) Then
        'We do something on the item
    Else
        DicByUser.Item(Cid).Add Pid, source
    End If
 Else
    Dim dicotoadd As New Scripting.Dictionary
    dicotoadd.Add Pid, source
    DicByUser.Add Cid, dicotoadd

Weirdly, the line before the last gives me the error : vba tells me that

Error 457 : this key is already associated with an element of collection

Then, if I go in debug mode and I try to display the number of elements in my object dicotoadd, I find 1, while the object was created at the line before.

I believe there is probably a problem in the way I put a dictionary in another one by always giving it the same name, otherwise I don’t see why a dictionary that I create one line above can already contain an element

What am I doing wrong in my procedure to create a nested dictionary in vba?

Edit : Solved by changing my code to the following, as suggested by Mat’s Mug

If DicByUser.Exists(Cid) Then
    If DicByUser.Item(Cid).Exists(Pid) Then
        'We do something on the item
    Else
        DicByUser.Item(Cid).Add Pid, source
    End If
 Else
    Dim dicotoadd As Scripting.Dictionary
    Set dicotoadd = New Scripting.Dictionary
    dicotoadd.Add Pid, source
    DicByUser.Add Cid, dicotoadd

I’m trying to create a dictionary of dictionary structure in vba

Basically, I start with a 3 column tables :

Product Id | Customer Id | Source

1 | 1 | A

1 | 2 | A

2 | 1 | A

3 | 1 | B

And I want to transform it into a main dictionary «DicByUser» where the keys are the user ids and the items are another dictionary that contain as keys the products visited by a client and as item the source code.

In that case, I would have

DicByUser= { 1 : { 1 : A , 2 : A, 3 : B}, 2 : {1 : A }}

My approach was to go through all the rows of my initial table then :

with Cid the customer Id,

Pid the product Id,

source the Source

If DicByUser.Exists(Cid) Then
    If DicByUser.Item(Cid).Exists(Pid) Then
        'We do something on the item
    Else
        DicByUser.Item(Cid).Add Pid, source
    End If
 Else
    Dim dicotoadd As New Scripting.Dictionary
    dicotoadd.Add Pid, source
    DicByUser.Add Cid, dicotoadd

Weirdly, the line before the last gives me the error : vba tells me that

Error 457 : this key is already associated with an element of collection

Then, if I go in debug mode and I try to display the number of elements in my object dicotoadd, I find 1, while the object was created at the line before.

I believe there is probably a problem in the way I put a dictionary in another one by always giving it the same name, otherwise I don’t see why a dictionary that I create one line above can already contain an element

What am I doing wrong in my procedure to create a nested dictionary in vba?

Edit : Solved by changing my code to the following, as suggested by Mat’s Mug

If DicByUser.Exists(Cid) Then
    If DicByUser.Item(Cid).Exists(Pid) Then
        'We do something on the item
    Else
        DicByUser.Item(Cid).Add Pid, source
    End If
 Else
    Dim dicotoadd As Scripting.Dictionary
    Set dicotoadd = New Scripting.Dictionary
    dicotoadd.Add Pid, source
    DicByUser.Add Cid, dicotoadd

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 = «PATHSQL 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.

r/excel

•

Hi, so I have a macro to copy and paste from one workbook to another. Sometimes it works. Other times I get error ‘457’ “this key is already associated with an element of this collection”. I’m not sure what this means. Like I said sometimes the macro works perfectly and during those times I don’t notice myself doing anything different. Visual basics highlights this for the error. https://i.imgur.com/Ml0aleJ.jpg. Thank you!