更新：VBA错误6在字典中迭代键时溢出

早上好，

我必须在Excel工作簿中的工作表“数据”和“循环计数数据库”。 本质上，我用我们networking文件中的SQL查询刷新“数据”工作表（完美地工作）。

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

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

这是我的“数据”表的头：

ABCD 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 

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

所以基本上，如果“项目”（列B）值出现在“周期盘点数据库”中，我不想做任何事情; 但是，如果“项目”不存在，我想将列A：D粘贴到“循环计数数据库”表的底部行上。 然后我会放入一个filter按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 

运行时错误6在线：

 If oCell.Value <> key Then 

我意识到我没有所有的花里胡哨的东西，我也不是在寻找你创造这些。 我只是想给你一些背景的全貌。 我真的只需要帮助复制新的信息，没有收到这个溢出代码…

谢谢！

更新：我现在可以重复/粘贴词典的第一个条目。 但for循环不会继续添加到其他行并重复第一行。 所以，我怀疑我有一个for循环的顺序问题：

 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 

结果是：

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

Answer 1

要遍历字典中的键，您需要使用.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和数据表创build一个字典。

 ' 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位，这在debugging时很有用。 最后将其更改回CreateObject('Scripting.Dictionary')有助于提高可移植性