Macro per Rinominare Files

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 As String, t As Date, NonElab As String, ck As Boolean
Corr = Range("A3:B10") ' <<<<<<<<<<<<<<< modificare oppure automatizzare !!!!!
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
            ck = False
            For j = 1 To UBound(Corr)
                If InStr(UCase(Left(mStr, 20)), UCase(Corr(j, 1))) > 0 Then
                    OldName = mDir & "\" & mFile
                    NewName = mDir & "\" & mFile & "." & Corr(j, 2)
                    Name OldName As NewName
                    ck = True
                    Exit For
                End If
            Next j
            If Not ck Then NonElab = NonElab & mFile & vbCrLf
        End If
        mFile = Dir
    Loop
  End If
End With
End Sub

mFile = Dir(mDir & "\*.")

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 lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Corr = Range("A3:B" & lr)
Set mFld = Application.FileDialog(msoFileDialogFolderPicker)
With mFld
  If .Show Then
    mDir = .SelectedItems(1)
    mFile = Dir(mDir & "\*.")
    Do While Len(mFile) > 0
            Open (mDir & "\" & mFile) For Binary As #1
            mStr = Input(LOF(1), #1)
            Close
            For j = 1 To UBound(Corr)
                If Corr(j, 1) <> "" And Corr(j, 2) <> "" Then
                    If InStr(UCase(Left(mStr, 20)), UCase(Corr(j, 1))) > 0 Then
                        OldName = mDir & "\" & mFile
                        NewName = mDir & "\" & mFile & "." & Corr(j, 2)
                        Name OldName As NewName
                        Exit For
                    End If
                End If
            Next j
        mFile = Dir
    Loop
  End If
End With
End Sub

Option Explicit
Sub Dodo5()
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 lr As Long, files As Long
Dim T
T = Now
' calcolo ultima riga colonna A
lr = Range("A" & Rows.Count).End(xlUp).Row

'crea array corrispondenze
Corr = Range("A1:B" & lr)

' file dialog
Set mFld = Application.FileDialog(msoFileDialogFolderPicker)
With mFld
  If .Show Then
    mDir = .SelectedItems(1) ' cartella selezionata
    mFile = Dir(mDir & "\*.") ' primo file

' inizio loop lettura cartella
    Do While Len(mFile) > 0
        files = files + 1
        Open (mDir & "\" & mFile) For Binary As #1 ' apre in binario il file
        mStr = Input(20, #1) ' stringa contenente (tutto il file), solo alcuni bytes
        Close ' chiude file
        For j = 1 To UBound(Corr) ' cerca se nei primi 20 crt c'è una corrispondenza
                If InStr(mStr, UCase(Corr(j, 1))) Then       ' ho messo io questa riga
                    OldName = mDir & "\" & mFile ' vecchio nome file
                    NewName = mDir & "\" & mFile & "." & Corr(j, 2) ' nuovo nome file con estensioner
                    Name OldName As NewName ' rinomina il file
                    Exit For
                End If
        Next j
        mFile = Dir ' legge successivo file
    Loop
  End If
End With
Range("C1").Value = Now - T
Range("D1").Value = files
End Sub

Sub DelNoExt()
mPath = "C:\TuaPath\*."
Shell "cmd /c del /F """ & mPath & """"
End Sub

Shell "cmd /c del /F """ & mDir & "\*." & """" 'elimina file senza estensione rimasti