Şifreli Excel Dosyalarını Toplu Şifre Kaldırma

[sembek]

Merhaba,

Şifreli olan excel dosyalarını toplu bir şekilde şifrelerini kaldırabilmek mümkün mü? Hepsinde aynı şifre var, kaydedilirken bu şekilde kaydedildi. Dosyaların içerisindeki verileri çekmem gerekiyor ama tek tek şifre girişiyle yapmak çok yorucu. Şifre girerek de bir otomasyon çözümü varsa oda olabilir. Yardımlarınızı bekliyorum. İyi çalışmalar.

 

[cems]

Hepsinde aynı sifre varsa ;
Yeni bir excel dosyası acın
alt+f11 beraber basarak vba kısmına gecin
sol menüde dosya adına sag tıklayarak yeni modul acın
Modul icine bu kodu yapıstırın ( onemli olan dosyaların oldugu klasor yolunu dogru yazın)
save ederken ( makro calısabilir seccenegini secin ) .xlsm olarak kaydedin
Calıstırıarak deneyin

Sub UnlockExcelFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim password As String
    Dim wb As Workbook
    
    ' Şifrenizi buraya girin
    password = "şifreniz"
    
    ' Excel dosyalarının bulunduğu klasörü seçin
    folderPath = "C:\path\to\your\excel\files\"
    
    ' Klasördeki tüm Excel dosyalarını açın ve şifreyi kaldırın
    fileName = Dir(folderPath & "*.xlsx")
    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & fileName, Password:=password)
        wb.SaveAs folderPath & "unlocked_" & fileName
        wb.Close
        fileName = Dir
    Loop
    
    MsgBox "Tüm dosyalar başarıyla şifresiz hale getirildi!"
End Sub

Dosyalar ve klasor sizde oldugundan deneme sansım yok

 

[sembek]

Hepsinde aynı sifre varsa ;
Yeni bir excel dosyası acın
alt+f11 beraber basarak vba kısmına gecin
sol menüde dosya adına sag tıklayarak yeni modul acın
Modul icine bu kodu yapıstırın ( onemli olan dosyaların oldugu klasor yolunu dogru yazın)
save ederken ( makro calısabilir seccenegini secin ) .xlsm olarak kaydedin
Calıstırıarak deneyin

Sub UnlockExcelFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim password As String
    Dim wb As Workbook
   
    ' Şifrenizi buraya girin
    password = "şifreniz"
   
    ' Excel dosyalarının bulunduğu klasörü seçin
    folderPath = "C:\path\to\your\excel\files\"
   
    ' Klasördeki tüm Excel dosyalarını açın ve şifreyi kaldırın
    fileName = Dir(folderPath & "*.xlsx")
    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & fileName, Password:=password)
        wb.SaveAs folderPath & "unlocked_" & fileName
        wb.Close
        fileName = Dir
    Loop
   
    MsgBox "Tüm dosyalar başarıyla şifresiz hale getirildi!"
End Sub

Dosyalar ve klasor sizde oldugundan deneme sansım yok

Merhaba, desteğiniz için teşekkürler.
Dosya yolu ve şifreyi doğru olarak giriyorum, msgbox çalışıyor ancak şifreler kalkmadı.

 

[pitchoute]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Sub SifreleriTopluKaldir()
    Dim dosyaAdi As String
    Dim klasorYolu As String
    Dim wb As Workbook
    Dim sifre As String
    klasorYolu = "C:\SifreliExcelDosyalar\"
    sifre = "buraya_sifrenizi_girin"
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    dosyaAdi = Dir(klasorYolu & "*.xlsx")
    
    Do While dosyaAdi <> ""
        Set wb = Workbooks.Open(Filename:=klasorYolu & dosyaAdi, Password:=sifre)
        wb.Password = ""
        wb.SaveAs Filename:=klasorYolu & dosyaAdi, Password:=""
        wb.Close
        dosyaAdi = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Şifre kaldırma işlemi tamamlandı."
End Sub

 

[sembek]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Sub SifreleriTopluKaldir()
    Dim dosyaAdi As String
    Dim klasorYolu As String
    Dim wb As Workbook
    Dim sifre As String
    klasorYolu = "C:\SifreliExcelDosyalar\"
    sifre = "buraya_sifrenizi_girin"
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    dosyaAdi = Dir(klasorYolu & "*.xlsx")
   
    Do While dosyaAdi <> ""
        Set wb = Workbooks.Open(Filename:=klasorYolu & dosyaAdi, Password:=sifre)
        wb.Password = ""
        wb.SaveAs Filename:=klasorYolu & dosyaAdi, Password:=""
        wb.Close
        dosyaAdi = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Şifre kaldırma işlemi tamamlandı."
End Sub

Merhaba, teşekkürler yanıtınız için ancak aynısı oldu. Şifre kaldırma işlemi tamamlandı. yazıyor ve değişen bir şey yok.