更新：VBA 遍历字典中的键时出现错误 6 溢出
Update: VBA error 6 Overflow when iterating over key in dictionary
早上好，
我必须在 Excel 工作簿中工作sheets "Data" 和 "Cycle Count Database"。本质上，我使用网络文件中的 SQL 查询刷新 "Data" sheet（效果很好）。
刷新后，我想将任何新值粘贴到 "Cycle Count Database" sheet 中。如果信息已经存在，我不想复制它；我只想添加新数据。实际上，我想确保如果我们添加一个新项目，我们正在执行该项目的循环计数，但不会从旧项目的 "Cycle Count Database" 中删除数据。
一般来说，新品应该不多。然而，在第一次填充传播sheet时，有23080个项目。
这是我的 "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
理想情况下，我只想复制 "Active"（A 列）列中具有 "A" 的行。 （"S" 表示该项目已暂停。将来如果某个项目从 "A" 更改为 "S" 我希望 "Cycle Count Database" sheet 将替换为 "S"，但这是一个单独的问题。）
所以基本上，如果 "Item"（B 列）值出现在 "Cycle Count Database" 中，我不想做任何事情；但是，如果 "Item" 不存在，我想将列 A:D 粘贴到 "Cycle Count Database" sheet 的底行。然后我会放入一个过滤器，按 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
我知道我没有所有的花里胡哨的东西，我也不想找你来创造这些。我只是想给你一些背景的全貌。我真的只是需要帮助复制新信息而没有收到此溢出代码...
谢谢！
更新：我现在可以repeat/paste字典的第一个词条了。但是 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
结果：
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') 有助于便携性
早上好，
我必须在 Excel 工作簿中工作sheets "Data" 和 "Cycle Count Database"。本质上，我使用网络文件中的 SQL 查询刷新 "Data" sheet（效果很好）。
刷新后，我想将任何新值粘贴到 "Cycle Count Database" sheet 中。如果信息已经存在，我不想复制它；我只想添加新数据。实际上，我想确保如果我们添加一个新项目，我们正在执行该项目的循环计数，但不会从旧项目的 "Cycle Count Database" 中删除数据。
一般来说，新品应该不多。然而，在第一次填充传播sheet时，有23080个项目。
这是我的 "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
理想情况下，我只想复制 "Active"（A 列）列中具有 "A" 的行。 （"S" 表示该项目已暂停。将来如果某个项目从 "A" 更改为 "S" 我希望 "Cycle Count Database" sheet 将替换为 "S"，但这是一个单独的问题。）
所以基本上，如果 "Item"（B 列）值出现在 "Cycle Count Database" 中，我不想做任何事情；但是，如果 "Item" 不存在，我想将列 A:D 粘贴到 "Cycle Count Database" sheet 的底行。然后我会放入一个过滤器，按 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
我知道我没有所有的花里胡哨的东西，我也不想找你来创造这些。我只是想给你一些背景的全貌。我真的只是需要帮助复制新信息而没有收到此溢出代码...
谢谢！
更新：我现在可以repeat/paste字典的第一个词条了。但是 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
结果：
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') 有助于便携性