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

selva2k25

New Member
Joined
Jul 11, 2011
Messages
1
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........................

Code:
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
 

Forum statistics

Threads
1,081,416
Messages
5,358,544
Members
400,503
Latest member
RedSquirrel

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top