VBA For...Next循环报错：集合键重复问题及修复方案

问题根源 #

1. 重复添加相同键到Dictionary：For j = 1 To NumofPac循环中，你反复给同一个inpackages(i)对象添加"weight"、"dimensions"等键，但Dictionary的键具有唯一性，第二次循环时就会触发「键已关联此集合的元素」错误。
2. 包裹对象未独立实例化：每个包裹需要是独立的Dictionary对象，你现在复用了同一个inpackages(i)，导致所有包裹指向同一对象，同时重复添加键触发报错。
3. 全局字典/集合未重置：inaccounts、inimageOptions这类字典在每次外层i循环中没有重新创建实例，会残留上一次循环的键值，也会导致重复添加错误。

修正后的完整代码 #

Sub CreateShiptest()

' Declare variables
Dim obj As Object
Dim i As Integer
Dim j As Integer ' 新增j的声明
Dim currentDateSave As String
Dim UserName, Password, isRequested As String
Dim requestFilename, responseFilename As String
Dim TotalRows As Long ' 修改为Long避免行数溢出

'partshipment
Dim plannedShippingDateAndTime As Dictionary ' 不提前New，需要时再实例化
Dim unitOfMeasurement As Dictionary

Dim content As Dictionary
Dim pickup As Dictionary
Dim outputImageProperties As Dictionary
Dim typeCode As Dictionary
Dim NumA As String
Dim ShipTime As String

'collection
Dim imageOptions() As Collection
ReDim imageOptions(50)
Dim inimageOptions As Dictionary


Dim customerReferences() As Collection
ReDim customerReferences(50)
Dim incustomerReferences As Dictionary


Dim accounts() As Collection
ReDim accounts(50)
Dim inaccounts As Dictionary


'partpackage
Dim packages() As Collection
ReDim packages(100)
Dim inpackages() As Dictionary
ReDim inpackages(100)
Dim weight As Dictionary
Dim dimensions() As Dictionary
ReDim dimensions(100)


TotalRows = Sheets("ShipmentDetail").Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row).Rows.Count

currentDateTime = Format(Date, "YYYY-MM-DD")


' Create an object
Set obj = CreateObject("Scripting.Dictionary")

'GetValueShipmentDetails
plannedDate = Format(Now, "yyyy-mm-dd" & "T" & "hh:mm:ss") & "GMT+00:00"


For i = 4 To TotalRows + 3
    ' 每次循环重新实例化所有字典/集合，避免残留旧数据
    Set pickup = New Dictionary
    Set inaccounts = New Dictionary
    Set accounts(i) = New Collection
    Set outputImageProperties = New Dictionary
    Set inimageOptions = New Dictionary
    Set imageOptions(i) = New Collection
    Set content = New Dictionary
    Set packages(i) = New Collection
    
'PickUp
  PUisRequested = False
  PuCloseT = "17:00"
  PULocation = "reception"
  
'account
  TypeC = "shipper"
  NumA = "561111111"

'imagePro
  prinDPI = 300
  encodFormat = "pdf"

'imageOp
  WaybillType = "waybillDoc"
  WaybillTempl = "ARCH_8X4"
  WaybillReq = True

'contentinfo
ConisCustomsDeclarable = False
Condescription = "test"
Conincoterm = "DAP"
Conunit = "metric"

'packages
NumofPac = 3
pweight = 1
'Pdimension
Plength = 1
Pwidth = 1
Pheight = 1

' Add data to the object
'ShipmentDetails
obj.Add "plannedShippingDateAndTime", plannedDate

'PickUp
obj.Add "pickup", pickup
    pickup.Add "isRequested", PUisRequested
    pickup.Add "closeTime", PuCloseT
    pickup.Add "location", PULocation

'account
obj.Add "accounts", accounts(i)
accounts(i).Add inaccounts
inaccounts.Add "typeCode", TypeC
inaccounts.Add "number", NumA

'imagePro
obj.Add "outputImageProperties", outputImageProperties
    outputImageProperties.Add "printerDPI", prinDPI
    outputImageProperties.Add "encodingFormat", encodFormat

'imageOp
outputImageProperties.Add "imageOptions", imageOptions(i)
    imageOptions(i).Add inimageOptions
    inimageOptions.Add "typeCode", WaybillType
    inimageOptions.Add "templateName", WaybillTempl
    inimageOptions.Add "isRequested", WaybillReq

'ContentDetail
obj.Add "content", content
    content("isCustomsDeclarable") = ConisCustomsDeclarable
    content("description") = Condescription
    content("incoterm") = Conincoterm
    content("unitOfMeasurement") = Conunit
    
'ContentPackages
content.Add "packages", packages(i)

' ------------------- 修改包裹循环逻辑 -------------------
For j = 1 To NumofPac
    ' 为每个包裹创建独立的字典和维度字典
    Set inpackages(i) = New Dictionary
    Dim dims As New Dictionary ' 每个包裹维度独立实例化
    
    dims.Add "length", Plength
    dims.Add "width", Pwidth
    dims.Add "height", Pheight
    
    inpackages(i).Add "weight", pweight
    inpackages(i).Add "dimensions", dims
    
    ' 将当前包裹添加到packages集合中
    packages(i).Add inpackages(i)
Next j
' -------------------------------------------------------

' Convert the object to a JSON string
jsonReq = JsonConverter.ConvertToJson(obj)
Debug.Print jsonReq

'Send the API request
' 清理对象，比逐个Remove更高效可靠
obj.RemoveAll
Set obj = Nothing

Set pickup = Nothing
Set inaccounts = Nothing
Set accounts(i) = Nothing
Set outputImageProperties = Nothing
Set inimageOptions = Nothing
Set imageOptions(i) = Nothing
Set content = Nothing
Set packages(i) = Nothing
Set inpackages(i) = Nothing
Set dims = Nothing

Next

End Sub

关键修改点 #

• 所有字典对象在每次外层i循环开始时重新实例化，避免复用旧对象导致键重复。
• 包裹循环中，为每个包裹创建独立的inpackages(i)和维度字典，确保每个包裹是独立对象，且只添加一次键。
• 清理对象时使用RemoveAll和Set xxx = Nothing，替代逐个Remove的繁琐操作。
• 修复变量声明：新增j的声明，将TotalRows改为Long类型，避免行数超过Integer上限。

内容的提问来源于stack exchange，提问作者Kamol M.