Makro İle Dosya Adlarını Değiştirme

[hakki83]

Merhaba hocalarımız,

Deneme.xlsm adında bir Excel dosyam var.

Bu dosyanın A sütununda, (A2'den itibaren) 60 adet dosya ismi yazılı (uzantısıyla beraber).

Bir de Test adında bir klasörüm var.

Bu klasörün içinde ise, yine 60 adet dosya var.

Fakat ben bu 60 adet dosyanın isimlerini, Excel dosyasındaki yazılı olan isimlerle değiştirmek istiyorum.

Bunu yapabilecek bir kod oluşturabilir miyiz?

 

[mustafa1205]

Sub dosyaisimleridegistir()
Dim ws As Worksheet
Dim folderPath As String
Dim oldFileName As String
Dim newFileName As String
Dim i As Integer


Set ws = ThisWorkbook.Sheets(1)


folderPath = "C:\Users\Administrator\Desktop\Test\" ' Test klasörünün tam yolunu buraya yazın


For i = 2 To 61 '
oldFileName = Dir(folderPath & "*.*")
If oldFileName <> "" Then
newFileName = ws.Cells(i, 1).Value

Name folderPath & oldFileName As folderPath & newFileName
End If
Next i

MsgBox "Dosya isimleri başarıyla değiştirildi!"
End Sub




yukarıdaki kodu deneyiniz. Test klasörünün tam dosya yolunu göstermeyi unutmayın

 

[hakki83]

Sub dosyaisimleridegistir()
Dim ws As Worksheet
Dim folderPath As String
Dim oldFileName As String
Dim newFileName As String
Dim i As Integer


Set ws = ThisWorkbook.Sheets(1)


folderPath = "C:\Users\Administrator\Desktop\Test\" ' Test klasörünün tam yolunu buraya yazın


For i = 2 To 61 '
oldFileName = Dir(folderPath & "*.*")
If oldFileName <> "" Then
newFileName = ws.Cells(i, 1).Value

Name folderPath & oldFileName As folderPath & newFileName
End If
Next i

MsgBox "Dosya isimleri başarıyla değiştirildi!"
End Sub




yukarıdaki kodu deneyiniz. Test klasörünün tam dosya yolunu göstermeyi unutmayın

Teşekkürler klasör yolu gösterdim, denemeler yaptım fakat dosya isimleri değişmedi neden bilmiyorum.

 

[RBozkurt]

Deneyiniz,

EVET seçilirse ekranda açılan pencereden klasörü seçeceksiniz ve A sütununa listelenecek.
Daha sonra HAYIR seçilip; tekrar aynı klasör seçilecek ve B sütununda yazılan değerlere göre yeniden adlandırma yapılacak.
*Dosya isimlerine uzantıları ekleyerek yazınız.

Sub ListeleVeYenidenAdlandir()
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim userChoice As VbMsgBoxResult

    Set ws = ThisWorkbook.Sheets("SAYFA1")
    userChoice = MsgBox("Klasörleri listelemek için EVET'i, dosyaları yeniden adlandırmak için HAYIR'ı seçin.", vbYesNo + vbQuestion, "Seçim Yapın")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Bir Klasör Seçin"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1) & "\"
    End With
    
    If userChoice = vbYes Then
        ws.Columns("A:B").ClearContents
        ws.Range("A1").Value = "ORJİNAL İSİM"
        ws.Range("B1").Value = "YENİ İSİM"
        
        fileName = Dir(folderPath & "*.*")
        i = 2
        Do While fileName <> ""
            ws.Cells(i, 1).Value = fileName
            fileName = Dir
            i = i + 1
        Loop
        MsgBox "Dosyalar başarıyla listelendi!", vbInformation
        
    ElseIf userChoice = vbNo Then
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastRow
            If ws.Cells(i, 2).Value <> "" Then
                Name folderPath & ws.Cells(i, 1).Value As folderPath & ws.Cells(i, 2).Value
            End If
        Next i
        MsgBox "Dosya isimleri başarıyla değiştirildi!", vbInformation
    End If
End Sub

 

[hakki83]

Deneyiniz,

EVET seçilirse ekranda açılan pencereden klasörü seçeceksiniz ve A sütununa listelenecek.
Daha sonra HAYIR seçilip; tekrar aynı klasör seçilecek ve B sütununda yazılan değerlere göre yeniden adlandırma yapılacak.
*Dosya isimlerine uzantıları ekleyerek yazınız.

Sub ListeleVeYenidenAdlandir()
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim userChoice As VbMsgBoxResult

    Set ws = ThisWorkbook.Sheets("SAYFA1")
    userChoice = MsgBox("Klasörleri listelemek için EVET'i, dosyaları yeniden adlandırmak için HAYIR'ı seçin.", vbYesNo + vbQuestion, "Seçim Yapın")
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Bir Klasör Seçin"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1) & "\"
    End With
   
    If userChoice = vbYes Then
        ws.Columns("A:B").ClearContents
        ws.Range("A1").Value = "ORJİNAL İSİM"
        ws.Range("B1").Value = "YENİ İSİM"
       
        fileName = Dir(folderPath & "*.*")
        i = 2
        Do While fileName <> ""
            ws.Cells(i, 1).Value = fileName
            fileName = Dir
            i = i + 1
        Loop
        MsgBox "Dosyalar başarıyla listelendi!", vbInformation
       
    ElseIf userChoice = vbNo Then
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastRow
            If ws.Cells(i, 2).Value <> "" Then
                Name folderPath & ws.Cells(i, 1).Value As folderPath & ws.Cells(i, 2).Value
            End If
        Next i
        MsgBox "Dosya isimleri başarıyla değiştirildi!", vbInformation
    End If
End Sub

RBozkurt hocam olmuştur. Emeğinize sağlık.

 

[hakki83]

Üstteki kurguda hatalar var, C:\Users\Administrator\Desktop\Test\ kısmınını düzeltip, şunu deneyin:

Sub DosyaIsimleriDegistir()
    Dim ws As Worksheet
    Dim folderPath As String
    Dim oldFileName As String
    Dim newFileName As String
    Dim i As Integer
    Dim fileCount As Integer

    Set ws = ThisWorkbook.Sheets(1)
    folderPath = "C:\Users\Administrator\Desktop\Test\"

    oldFileName = Dir(folderPath & "*.*")
    fileCount = 2

    Do While oldFileName <> ""
        newFileName = ws.Cells(fileCount, 1).Value
  
        If InStrRev(newFileName, ".") = 0 Then
            newFileName = newFileName & Mid(oldFileName, InStrRev(oldFileName, "."))
        End If
  
        On Error Resume Next
        Name folderPath & oldFileName As folderPath & newFileName
        If Err.Number <> 0 Then
            MsgBox "Dosya adı değiştirilemedi: " & oldFileName & " -> " & newFileName, vbExclamation
            Err.Clear
        End If
        On Error GoTo 0
  
        oldFileName = Dir
        fileCount = fileCount + 1
  
        If ws.Cells(fileCount, 1).Value = "" Then Exit Do
    Loop

HücrelereFısıldayanAdam Hocam emeğinize sağlık, kodda bir eksiklik olabilir mi? İsimler değişmedi.

 

[muratgunay48]

HücrelereFısıldayanAdam Hocam emeğinize sağlık, kodda bir eksiklik olabilir mi? İsimler değişmedi.

@RBozkurt hocamın eline emeğine sağlık. Kod gayet güzel çalışıyor. İsimler değişti.

 

[RBozkurt]

@RBozkurt hocamın eline emeğine sağlık. Kod gayet güzel çalışıyor. İsimler değişti.

Ekli dosyayı görüntüle 253485

@muratgunay48 hocam bende denemiştim paylaşmadan önce. Sıkıntı yoktu çalışıyor

 

[hakki83]

@RBozkurt hocamın eline emeğine sağlık. Kod gayet güzel çalışıyor. İsimler değişti.

Mesajımıdan alıntı yapmışsınız da
RBozkurt hocamın kodlarına zaten çalışmıyor demedim.

Dikkatli bakarsanız başka bir üyenin paylaştığı kodlardan bahsediyordum.

 

[muratgunay48]

Mesajımıdan alıntı yapmışsınız da
RBozkurt hocamın kodlarına zaten çalışmıyor demedim.

Dikkatli bakarsanız başka bir üyenin paylaştığı kodlardan bahsediyordum.

O taktirde ben yanlış anlamışım. Özürlerimi kabul edin lütfen.

 

[hakki83]

O taktirde ben yanlış anlamışım. Özürlerimi kabul edin lütfen.

Ne demek. Canınız sağ olsun.