Update: VBA error 6 Overflow when iterating over key in dictionary

Question

Good morning,

I have to worksheets "Data" and "Cycle Count Database" in an Excel workbook. Essentially, I refresh the "Data" sheet with a SQL query from our network files (which works perfectly).

After the refresh, I want to paste any new values into the "Cycle Count Database" sheet. If the information is already present, I don't want to copy over it; I only want to add new data. Practically, I want to make sure that if we add a new item that we are performing a cycle count of that item but not erase the data from the "Cycle Count Database" from old items.

Generally, speaking, there shouldn't be many new items. However, in populating the spreadsheet for the first time, there are 23080 items.

Here's the head of my "Data" sheet:

    A       B          C                                D
 1  Active  Item       Description                      ABC
 2  A       A-FUL      "A" FULL SHIM KIT (2" X 2")      B
 3  A       A-MINI     "A" MINI SHIM KIT (2" X 2")      C
 4  A       A-SHIMBOX  BLACK BOX FOR 2X2 SHIM KIT       X
 5  A       A-001      A (2" X 2").001" SHIM PACK/20    C
 6  S       A-002      A (2" X 2").002" SHIM PACK/20    C

Ideally I would like to copy over only rows that have "A" in the "Active" (Column A) column. ("S" denotes the item is suspended. In the future if an item has changed to "S" from "A" I would like the "A" on the "Cycle Count Database" sheet to be replaced with "S", but that's a separate issue.)

So essentially, if the "Item" (Column B) value is present in the "Cycle Count Database", I don't want to do anything; however if the "Item" is not present, I'd like to paste Columns A:D onto the bottom row of the "Cycle Count Database" sheet. Then I would put in a filter to filter alphabetically by column B.

Here's what I have going so far:

Option Explicit

Sub RefreshData()

    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    ' Set workbook definitions
    Dim wbk As Workbook
    Set wbk = ThisWorkbook
    ' Set worksheet definitions
    Dim shtData As Worksheet
    Set shtData = wbk.Sheets("Data")
    Dim shtCC As Worksheet
    Set shtCC = wbk.Sheets("Cycle Count Database")


    ' Refresh SQL query for data from AS400
    wbk.RefreshAll

    ' Create dictionary of items
    Dim Dic As Object, key As Variant, oCell As Range, i&
    Set Dic = CreateObject("Scripting.Dictionary")

    ' Calculate number of rows in Data sheet
    i = shtData.Cells.SpecialCells(xlCellTypeLastCell).Row

    ' Store Data key, values in Dictionary
    For Each oCell In shtData.Range("B2:B" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 1).Value
        End If
    Next

    'Debug.Print (Dic.Count)

    ' Calculate number of rows in Dic + number of rows in database
    i = Dic.Count + shtCC.Cells.SpecialCells(xlCellTypeLastCell).Row + 1

    ' If dictionary key not present, paste into database
    For Each oCell In shtCC.Range("B2:B" & i)
        For Each key In Dic
            If oCell.Value <> key Then
                oCell.Value = key
                oCell.Offset(, 1).Value = Dic(key)
            End If
        Next
    Next

    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

With a Run-time error 6 on line:

If oCell.Value <> key Then

I realize I don't have all the bells and whistles, nor am I looking for you to create those. I just wanted to give you the whole picture for some context. I really just need help on copying the new information over without receiving this overflow code...

Thanks!

Update: I can now repeat/paste the first entry of the dictionary. But the for loop doesn't go on to the additional rows and duplicates the first row over and over. So, I suspect I have an issue with the order of the for loops somewhere:

Option Explicit

Sub RefreshData()

    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    ' Set workbook definitions
    Dim wbk As Workbook
    Set wbk = ThisWorkbook
    ' Set worksheet definitions
    Dim shtData As Worksheet
    Set shtData = wbk.Sheets("Data")
    Dim shtCC As Worksheet
    Set shtCC = wbk.Sheets("Cycle Count Database")


    ' Refresh SQL query for data from AS400
    'wbk.RefreshAll

    ' Create dictionary of items
    Dim Dic As Object, key As Variant, oCell As Range, i&
    Set Dic = CreateObject("Scripting.Dictionary")

    ' Calculate number of rows in Data sheet
    i = shtData.Cells.SpecialCells(xlCellTypeLastCell).Row

    ' Store Data key, values in Dictionary
    For Each oCell In shtData.Range("B2:B" & i)
        If Not Dic.Exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 1).Value
        End If
    Next

    'Debug.Print (Dic.Count)

    ' Calculate number of rows in Dic + number of rows in database
    i = Dic.Count + shtCC.Cells.SpecialCells(xlCellTypeLastCell).Row + 1

    ' If dictionary key not present, paste into database
    For Each oCell In shtCC.Range("B2:B" & i)
        For Each key In Dic
            If Not Dic.Exists(oCell.Value) Then
                    oCell.Value = key
                    oCell.Offset(, 1).Value = Dic(key)
            End If
        Next
    Next

    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

With the result:

  A      B      C                            D
1 Active Item   Description                  ABC
2        A-FUL  "A" FULL SHIM KIT (2" X 2") 
3        A-FUL  "A" FULL SHIM KIT (2" X 2") 
4        A-FUL  "A" FULL SHIM KIT (2" X 2") 
5        A-FUL  "A" FULL SHIM KIT (2" X 2") 
...

NickSlash · Accepted Answer

To iterate over the keys in a dictionary you need to use the .Keys() method, using just Dic wont/shouldnt work.

Option Explicit

Sub RefreshData()

    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    ' Set workbook definitions
    Dim wbk As Workbook
    Set wbk = ThisWorkbook
    ' Set worksheet definitions
    Dim shtData As Worksheet
    Set shtData = wbk.Sheets("Data")
    Dim shtCC As Worksheet
    Set shtCC = wbk.Sheets("Cycle Count Database")


    ' Refresh SQL query for data from AS400
    'wbk.RefreshAll

    ' Create dictionary of items
    Dim Dic As Object, key As Variant, oCell As Range, i&
    Set Dic = CreateObject("Scripting.Dictionary")

    ' Calculate number of rows in Data sheet
    i = shtData.Cells.SpecialCells(xlCellTypeLastCell).Row

    ' Store Data key, values in Dictionary
    For Each oCell In shtData.Range("B2:B" & i)
        If Not Dic.Exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 1).Value
        End If
    Next

    'Debug.Print (Dic.Count)

    ' Calculate number of rows in Dic + number of rows in database
    i = Dic.Count + shtCC.Cells.SpecialCells(xlCellTypeLastCell).Row + 1

'-------------THIS---------------------
    ' If dictionary key not present, paste into database
    For Each oCell In shtCC.Range("B2:B" & i)
        For Each key In Dic.Keys
            If Not Dic.Exists(oCell.Value) Then
                    oCell.Value = key
                    oCell.Offset(, 1).Value = Dic(key)
            End If
        Next
    Next
'-----------------------------------------

    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Update - I don't know if I completely understand what you are trying to do, so the following pseudo-code might not help at all.

' Populate Dictionary with data from CCD
Dim CCDic as Dictionary
For Each Cell In CCD.Range
    If Not CCDic.Exists(Cell.Value) Then
        CCDic.Add Cell.Value, Cell.Offset(,1).Value
    End If
Next

' Populate another dictionary from Data
Dim DDic as Dictionary
For Each Cell in Data.Range
    If Not DDic.Exists(Cell.Value) Then
        DDic.Add Cell.Value, Cell.Offset(,1).Value
    End If
End If

' Remove any duplicate items from DDic (leaving only new items)
Dim Key As Variant
For Each Key In DDic.Keys
    If CCDic.Exists(Key) Then
        DDic.Remove Key
    End If
Next    

' Iterate over DDic and append data to CCD
For Each Key In DDic.Keys
    ' Code to do that
Next

Update 2 - I thought about it a little more and realised that you don't need to create a dictionary for both CCD and Data sheets.

' Populate Dictionary with data from CCD
Dim CCDic as Dictionary
For Each Cell In CCD.Range
    If Not CCDic.Exists(Cell.Value) Then
        CCDic.Add Cell.Value, Cell.Offset(,1).Value
    End If
Next

' Look for and keep new records
Dim NewDic as Dictionary
For Each Cell In Data.Range
    If Not CCDic.Exists(Cell.Value) Then
        If Not NewDic.Exists(Cell.Value) Then
            NewDic.Add Cell.Value, Cell.Offset(,1).Value
        End If
    End If  
Next

' Iterate over NewDic and append data to CCD
For Each Key In NewDic.Keys
    ' Code to do that
Next

If you add a reference to "Microsoft Scripting Runtime" in the script editor it will add the Dictionary object to VBA so you can do Dim X As Dictionary and it adds Intellisense bits for them too which is helpful when debugging. Changing it back to CreateObject('Scripting.Dictionary') in the end helps with portability

Update: VBA error 6 Overflow when iterating over key in dictionary

Answers (1)

Related Questions