Macro to rename .jpg and .png files with similar names

[selva2k25]

Hi Team,

I need to write a Macro, which will find all .jpg and .png files in a folder with same names and rname them seq as 1.jpg, 1.png, 2.jpg, 2.png and so on...................

Please note that even after renaming both files will be under the same names only...............But instead of any other name it has to be from 1, 2, 3, and so on..................

For example assume we have Loc.jpg and Loc.png.............After running the Macro, it has to be renamed as 1.jpg, 1.png..................Please advice................

I already found have a sample code...........But unfortunatly it does not work for me............Please find the code below and help me on the same........................

Option Explicit
Sub SerializeFiles()
  Dim Counter As Long
  Dim Dict As Object
  Dim Ext As String
  Dim FileName As Variant
  Dim Path As Variant
  Dim oShell As Object
  Dim oFolder As Variant
  Dim oFolderItem As Variant
 
    Path = "C:\Users\SM26018\Pictures\"
    ChDir Path
 
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
 
    Set oShell = CreateObject("Shell.Application")
 
      Set oFolder = oShell.Namespace(Path)
 
      For Each oFolderItem In oFolder.Items
        With oFolderItem
          Ext = LCase(Right(.Name, 3))
 
          If .Type <> "File Folder" And (Ext = "jpg" Or Ext = "png") Then
             FileName = Left(.Name, InStr(1, .Name, ".") - 1)
               If Not Dict.Exists(FileName) Then
                  Dict.Add FileName, 0
               Else
                  Counter = Counter + 1
                  Dict(FileName) = Counter
               End If
          End If
        End With
      Next oFolderItem
 
      For Each FileName In Dict.Keys
       'Change only matched file names
        If Dict(FileName) <> 0 Then
           Name FileName & ".jpg" As Dict(FileName) & ".jpg"
           Name FileName & ".png" As Dict(FileName) & ".png"
        End If
      Next FileName
 
End Sub