ExcelのVBA：大量の画像ファイルのリネームと自動フォルダ分けを次の条件でできませんでしょうか？

※途中、回答に誤りがありましたが、修正完了しました。

きれいなソースではなく、お恥ずかしいですが…
コード１、商品名１、商品名２のリスト一覧表のシートをアクティブにして実行してください。

下記項目については、ソース上部で適宜変更してご使用ください。

・画像ファイルのパス、リネームファイルのパス
・Excelシートのコード１の範囲
・画像ファイルの拡張子がjpgでない場合

※コード１、商品名１、商品名２は連続した列(例:A列、B列、C列)とします
※連番が999を超えた場合は、ファイル名の変更、フォルダ分けをしません

以上、不明な点がありましたら、コメントにてお知らせください。

Option Explicit

Sub Macro1()

Dim pictdir As String
Dim rendir As String
Dim dd As String
Dim dr As String
Dim cn As String
Dim pn As String
Dim px As String
Dim ps As Long
Dim i As Integer
Dim obj As Object
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'### 画像ファイルのパス 最後は\
pictdir = "C:\Users\user\Desktop\pict\pict\"
'### リネームファイルのパス 最後は\
rendir = "C:\Users\user\Desktop\pict\リネームファイル\"
'### コード1の範囲
dr = "A1:A3"
'### 画像ファイルの拡張子
px = ".jpg"

dd = Dir(pictdir & "*" & px)
Do Until dd = ""
    ps = InStr(dd, "_")
    If ps > 0 Then
        cn = Left(dd, ps - 1)
        Set obj = Range(dr).Cells.Find(cn)
        If Not obj Is Nothing Then
            pn = obj.Offset(0, 1) & "_" & obj.Offset(0, 2)
            If FSO.FolderExists(rendir & pn) = False Then
                MkDir rendir & pn
            End If
            
            For i = 1 To 999
                If FSO.FileExists(rendir & pn & "\" & pn & "_" & Format(i, "000") & px) = False Then
                    Exit For
                End If
            Next
            
            If i > 0 And i < 1000 Then
                Name pictdir & dd As rendir & pn & "\" & pn & "_" & Format(i, "000") & px
            End If
        End If
    End If
    dd = Dir()
Loop

End Sub

全ての拡張子に対応するように変更を行いました。

なお、画像ファイルかどうかは判断できないので、フォルダ内のすべてのファイルを処理します。ただし、ファイル名に _ が含まれないもの、_ が含まれてもコード１に対応するコードがリストに無いものは、処理の段階ではじかれます。(コード１がリストにあると、ExcelやWordのファイルも処理対象となります)

《コード１が、「!73C301B3」の場合、36行目で止まってしまいます。》との事ですが、下記の情報を教えてください。

・36行目のVBAの記述
・エラーメッセージ
・!73C301B3 に対応する商品名１、商品名２
　※この商品名１、商品名２ですが、ファイル名に使用できない文字が含まれていませんか？
　　含まれている場合、どのように処理をしますか？
　　→とりあえずの対処として、リストからファイル名に使用できない文字は
　　　置換で取り除いてはいかがでしょうか？

Sub Macro2()

Dim pictdir As String
Dim rendir As String
Dim dr As String
Dim dd As String
Dim cn As String
Dim pn As String
Dim px As String
Dim fn As Integer
Dim ps As Long
Dim i As Integer
Dim ddo As Object
Dim obj As Object
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'### 画像ファイルのパス 最後は\
pictdir = "C:\Users\user\Desktop\pict\pict\"
'### リネームファイルのパス 最後は\
rendir = "C:\Users\user\Desktop\pict\リネームファイル\"
'### コード1の範囲
dr = "A1:A3"

For Each ddo In FSO.GetFolder(pictdir).Files
    dd = ddo.Name
    ps = InStr(dd, "_")
    If ps > 0 Then
        cn = Left(dd, ps - 1)
        Set obj = Range(dr).Cells.Find(cn)
        If Not obj Is Nothing Then
            pn = obj.Offset(0, 1) & "_" & obj.Offset(0, 2)
            If FSO.FolderExists(rendir & pn) = False Then
                MkDir rendir & pn
            End If
            
            px = FSO.GetExtensionName(dd)
            For i = 1 To 999
                If Dir(rendir & pn & "\" & pn & "_" & Format(i, "000") & ".*") = "" Then
                    Exit For
                End If
            Next
            
            If i > 0 And i < 1000 Then
                Name pictdir & dd As rendir & pn & "\" & pn & "_" & Format(i, "000") & "." & px
            End If
        End If
    End If
Next

End Sub