行き詰っているので助けて頂きたいです。

INVOICEというSheetのC列に商品コード、I列に製品名、D列に数量が入力された
シートがあり、I列の製品名が同じ括りの中で、Ｃ列の商品コードに重複があった
場合に重複先頭行へしその商品コードの数量を合計した数値を出力したうえで、
先頭行以外の重複行を削除するマクロがあります。

下記マクロで希望した結果は出力されるのですが、Ｄ列に文字列があった場合や指定した行以降からマクロを実行したい場合に実行時エラー13が出てどうしてもエラーが修正できません。

ご指摘頂けると幸いです。

Sub RemoveDuplicateRowsAndSumD()
Dim lastRow As Long
Dim ws As Worksheet

Set ws = Sheets("INVOICE")
lastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row 'C列の最終行を取得

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Dim i As Long
For i = lastRow To 2 Step -1 '最終行から上に向かってループ
    Dim c As String, iVal As String
    Dim d As Double
    
    c = ws.Cells(i, "C").Value
    iVal = ws.Cells(i, "I").Value
    d = ws.Cells(i, "D").Value　　←ここ行でエラーがでます。
    
    If dict.Exists(c & iVal) Then '重複データの場合
        dict(c & iVal) = dict(c & iVal) + d '合計値を加算
        ws.Rows(i).Delete '重複行を削除
    Else '重複していない場合
        dict.Add c & iVal, d '合計値を初期化
    End If
Next i

'重複先頭行に合計値を出力
For i = 2 To lastRow
    Dim key As String
    key = ws.Cells(i, "C").Value & ws.Cells(i, "I").Value
    
    If dict.Exists(key) Then
        ws.Cells(i, "D").Value = dict(key)　　←ここではオブジェクト定義エラーがよくでます。
        dict.Remove key
    End If
Next i

End Sub

>Ｄ列に文字列があった場合
判定を追加し、文字列なら例えば0とかに置き換えれば良いのではと思います。

>指定した行以降からマクロを実行
指定可能にコーディングすれば良いのではと思います。

かなり変形してしまいましたが一例です。

Sub RemoveDuplicateRowsAndSumD()
    Dim r As Range, rr As Range
    Dim dict As Object
    Dim c As String
    Dim d As Double
    Dim cof As Long
    Dim 指定した行 As Range
    
    On Error Resume Next
    Set 指定した行 = Application.InputBox("集計シートの開始行を指定下さい", Type:=8)
    On Error GoTo 0
    If 指定した行 Is Nothing Then Exit Sub
    Set dict = CreateObject("Scripting.Dictionary")
    With 指定した行.Worksheet
        cof = .Range("I1").Column - .Range("C1").Column
        Set rr = .Range("C" & 指定した行.Row, .Cells(.Rows.Count, "C").End(xlUp))
    End With
    For Each r In rr
        c = r.Value & vbTab & r.Offset(, cof).Value
        d = IIf(IsNumeric(r.Offset(, 1).Value), r.Offset(, 1).Value, 0) '★数値判定し、処置
        If dict.Exists(c) Then          '重複データの場合
            r.Offset(, 1).Value = ""        'Blank
        Else                            '重複していない場合
            r.Offset(, 1).Value = 1         'Blank以外
        End If
        dict(c) = dict(c) + d           '合計値を加算
    Next
    '重複行削除
    On Error Resume Next
    rr.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    '合計値を出力   '★dict.count(表範囲)以外は無視
    rr.Offset(, 1).Value = Application.Transpose(dict.items)
    Application.Goto 指定した行
End Sub

kazuo様　ご回答頂きありがとうございます。


ご提示頂いた修正コードで希望する結果に至る事ができました。
ありがとうございます。

下記が頂いたコードを元に変更したコードになります。
追加でI列が空白な場合は処理をスキップするコードを
For分に追記したいのですが、何故かまたオブジェクトエラーが
でて頓挫を繰り返しています。
また煮詰まったら改めて質問を投稿しますので、その時はまたお力添え頂ければ
幸いです。


Sub RemoveDuplicateRowsAndSumD()
    Dim r As Range, rr As Range
    Dim dict As Object
    Dim c As String
    Dim d As Double
    Dim cof As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets("INVOICE")
        cof = .Range("I1").Column - .Range("C1").Column
        Set rr = .Range("C65", .Cells(.Rows.Count, "C").End(xlUp))
    End With
    For Each r In rr
        c = r.Value & vbTab & r.Offset(, cof).Value
        d = IIf(IsNumeric(r.Offset(, 1).Value), r.Offset(, 1).Value, 0) '★数値判定し、処置
        If dict.Exists(c) Then          '重複データの場合
            r.Offset(, 1).Value = ""        'Blank
        Else                            '重複していない場合
            r.Offset(, 1).Value = 1         'Blank以外
        End If
        dict(c) = dict(c) + d           '合計値を加算
    Next
    '重複行削除
    On Error Resume Next
    rr.Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    '合計値を出力   '★dict.count(表範囲)以外は無視
    rr.Offset(, 1).Value = Application.Transpose(dict.items)
End Sub