Macro per Rinominare Files

Sub AddExt()
Dim mFld As FileDialog, Corr As Variant, mFile As String, mDir As String
Dim OldName As String, NewName As String, j As Long
Corr = Range("A3:B10")
Set mFld = Application.FileDialog(msoFileDialogFolderPicker)
With mFld
If .Show Then
    mDir = .SelectedItems(1)
    mFile = Dir(mDir & "\*.*")
    Stop
    For j = 1 To UBound(Corr)
        If InStr(mFile, Corr(j, 1)) > 0 Then
            OldName = mFld & "\" & mFile
            NewName = mFld & "\" & mFile & "." & Corr(j, 2)
            Name OldFile As NewName
        End If
    Next j
End If
End With
End Sub

If InStr(mFile, Corr(j, 1)) > 0 Then

If InStr(mFile, Left(Corr(j, 1), 20)) > 0 Then

MsgBox InStr(mFile, Left(Corr(j, 1), 20)) 

If InStr(mFile, Corr(j, 1)) > 0 Then

If mFile Like "*" & Corr(j, 1) & "*" Then

C:\Users\bysal\Desktop\WEBP\f_000148
che diventa
C:\Users\bysal\Desktop\WEBP\f_000148.jpg

Option Explicit
Sub test()
    Dim Path As String
    Dim DialogBox As FileDialog
    Dim FileOpen As String
    Dim Cerca As Integer
    Dim arrayCerca As Variant
    Dim arrayRinomina As Variant
    Dim x As Long
    arrayCerca = Array("WEBP", "JFIF", "GIF", "PNG", "BMP", "ID3", "MP4", "MM")
    arrayRinomina = Array(".WEBP", ".JPG", ".GIF", ".PNG", ".BMP", ".MP3", ".MP4", ".TIF")
    On Error Resume Next
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Seleziona la Cartella"
    Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
    If DialogBox.Show = -1 Then Path = DialogBox.SelectedItems(1)
    Path = DialogBox.SelectedItems(1)
    If Path = "" Then Exit Sub
    FileOpen = Dir(Path & "\*.")
    Do While FileOpen <> ""
        On Error GoTo salta       'doveva servire per l'errore con file non riconosciuti
        Workbooks.Open Path & "\" & FileOpen, ReadOnly:=True
        For x = LBound(arrayCerca) To UBound(arrayCerca)
            Workbooks(FileOpen).Activate
            Cerca = InStr(1, Range("A1").Value, arrayCerca(x), vbTextCompare)
            If Cerca > 0 Then Exit For    'trovato prima della fine dell'array
        Next x
        Workbooks(FileOpen).Close False
        If Cerca > 0 Then Name Path & "\" & FileOpen As Path & "\" & FileOpen & arrayRinomina(x)  'rinomina
salta:
        FileOpen = Dir
    Loop
End Sub

Name OldName As NewName

Option Explicit
Sub Leo()
Dim MioFile As Variant, Corr As Variant, mFile As String, mStr As String
Dim OldName As String, NewName As String, j As Long, mFld As Object, mDir As String
Dim GetExt
Corr = Range("A3:B10")
Set mFld = Application.FileDialog(msoFileDialogFolderPicker)
With mFld
  If .Show Then
    mDir = .SelectedItems(1)
    mFile = Dir(mDir & "\*.*")
    Do While Len(mFile) > 0
        GetExt = Split(mFile, ".")(UBound(Split(mFile, ".")))
        If GetExt = mFile Then
            Open (mDir & "\" & mFile) For Binary As #1
            mStr = Input(LOF(1), #1)
            Close
            For j = 1 To UBound(Corr)
                If InStr(mStr, Corr(j, 1)) > 0 Then
                    OldName = mDir & "\" & mFile
                    NewName = mDir & "\" & mFile & "." & Corr(j, 2)
                    Name OldName As NewName
                    Exit For
                End If
            Next j
        End If
        mFile = Dir
    Loop
  End If
End With
End Sub