Klasördeki dosya isimlerini Excel (VBA) Makro Kullanarak Değiştir!

tarihinde gönderilmiş tarafından

Aşağıdaki kodlar başka bir Excel kullanıcısı tarafından oluşturulmuş vba kodlarıdır. Kodlara sürekli ihtiyaç duymamdan ötürü her hangi bir revize yapmadan kaynak göstererek direk ekledim. Faydalı olması dileğimle…

Bu Kod Dizini Bulur ve A1 hücresine dizin adını yazar.

Sub DosyaYoluBul()

    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    With fd

        If .Show = -1 Then

            For Each vrtSelectedItem In .SelectedItems
                Range("A1") = vrtSelectedItem & Application.PathSeparator
                Liste Range("A1").Text
            Next vrtSelectedItem
           
        End If
       
    End With

    Set fd = Nothing

End Sub

Bu kod Bulunan Dizindeki Dosyaları Listeler, Otomatik çağrılır, ilk kod bunu yapar.

Kod:

Sub Liste(Yol As String)

    Dim dosya As String, i As Long

    Application.ScreenUpdating = False
    i = Cells(Rows.Count, "A").End(3).Row
    If i < 2 Then i = 2
    Range("A2:B" & i).ClearContents
   
    dosya = Dir(Yol & "*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = dosya
        dosya = Dir
    Wend
   
End Sub

Aşağıdaki kodlar ise A sütununda listelenen (Uzantıları ile birlikte) B sütunundaki yeni adı ile değiştirilir. Yeni adı yazarken uzantıyı yazmaya gerek yok, çünkü A sütunundan uzantıyı otomatik olarak alır. B sütunundaki hücre boş ise karşılığındaki A sütunundaki dosyada değişiklik yapmaz.

Kod:

Sub Degistir()

    Dim DsyBas  As String, _
        i       As Long, _
        j       As Integer, _
        Adt     As Integer, _
        Uzn     As String, _
        Uzanti  As String, _
        Yol     As String
           
    Uzn = Application.InputBox("Uzantısı Olmayan Dosyaların Uzantısı Ne Olsun?", "Sordum Gitti Valla", ".mp4", Type:=2)
   
    Yol = Application.WorksheetFunction.Trim(Range("A1"))
    If Not Right(Yol, 1) = "\" Then Yol = Yol & Application.PathSeparator
   
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
   
        If Not Cells(i, "B") = "" Then
       
            Adt = Adt + 1
            j = InStr(1, StrReverse(Cells(i, "A")), ".", vbTextCompare)
            If j > 0 Then
                Uzanti = Right(Cells(i, "A"), j)
            Else
                Uzanti = Uzn
            End If
               
            Name Yol & Cells(i, "A") As Yol & Cells(i, "B") & Uzanti
           
        End If
       
    Next i
   
    MsgBox Adt & " adet dosya adı değiştirildi...", vbInformation, "Bilgi"
   
End Sub

Kaynak: https://www.excel.web.tr

133 views