Excel 更新：迭代字典中的键时发生VBA错误6溢出

早上好

我必须在Excel工作簿中创建工作表“数据”和“循环计数数据库”。从本质上讲，我使用来自网络文件的SQL查询刷新“数据”表（这非常有效）

刷新后，我想将任何新值粘贴到“循环计数数据库”表中。如果信息已经存在，我不想复制它；我只想添加新数据。实际上，我想确保，如果我们添加一个新项目，我们将对该项目执行周期计数，但不会从旧项目中删除“周期计数数据库”中的数据

一般来说，应该没有太多的新项目。但是，在第一次填充电子表格时，共有23080项

以下是我的“数据”表的标题：

理想情况下，我希望只复制“活动”（列A）列中有“A”的行。（“S”表示项目暂停。将来如果项目从“A”更改为“S”，我希望“循环计数数据库”表上的“A”替换为“S”，但这是一个单独的问题。）

所以本质上，如果“循环计数数据库”中存在“项”（B列）值，我不想做任何事情；但是，如果“Item”不存在，我想将A:d列粘贴到“Cycle Count Database”工作表的底行。然后我会放入一个过滤器，按字母顺序按B列过滤

以下是我到目前为止所做的：

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

结果为：

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

  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") 
...

---

要迭代字典中的键，您需要使用.keys（）方法，只使用

Dic

wont/shouldnt

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

更新-我不知道我是否完全理解您试图做什么，所以下面的伪代码可能根本没有帮助

' 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

更新2-我考虑了一下，意识到你不需要为CCD和数据表创建字典

' 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

---

如果在脚本编辑器中添加对“Microsoft Scripting Runtime”的引用，它会将Dictionary对象添加到VBA中，这样您就可以执行Dim X As Dictionary，并为它们添加Intellisense位，这在调试时很有帮助。最后将其改回

CreateObject（'Scripting.Dictionary'）

有助于提高可移植性

我认为您没有正确地遍历字典，请参见：。@NickSlash如果我将代码改为

如果oCell.Value=key，那么

只要存在匹配项，代码就可以正常工作。但我想要的是相反的效果，如果值不等于键，我想粘贴它。我仍然得到与以前相同的结果：代码反复粘贴第一行

A-FUL“A”FULL SHIM KIT（2“x2”）

而不是一次粘贴该行并继续下一项（即“A-MINI”）。非常感谢。我们不得不花点时间编写代码，但您的伪代码对框架非常有帮助。

' 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

' 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