Ş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.

 

[sembek]

Konuyu ChatGPT ile çözdüm. Daha sonra ihtiyacı olabilecek birileri olursa diye kodu aşağıya ekliyorum. Benim işlemimde tüm dosyalardaki şifreler aynıydı. Hepsi aynı olduğunda kod çalışır. Kolay gelsin herkese.
DosyaParolası kısmına parolayı,
targetFolder kısmına dosyaların yer aldığı klasörü yazın sonrası dosya adetine göre sürede bitiyor.

Sub RemovePasswordsFromMultipleXLS_ProgressDebugPrint()

    Dim targetFolder As String
    Dim fileName As String
    Dim wb As Workbook
    Dim currentFilePath As String
    
    Dim currentCount As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Const filePassword As String = "DosyaParolası"
    targetFolder = "C:\Path\To\Folder\"
    
    fileName = Dir(targetFolder & "*.xls")
    
    Do While fileName <> ""
        currentCount = currentCount + 1
        
        ' Immediate Window'a yaz (Alt+F11 -> View -> Immediate Window)
        Debug.Print currentCount & ". işleniyor: " & fileName
        
        currentFilePath = targetFolder & fileName
        
        On Error Resume Next
        Set wb = Workbooks.Open(Filename:=currentFilePath, Password:=filePassword)
        If Not wb Is Nothing Then
            
            On Error GoTo 0
            
            wb.Password = ""
            wb.WritePassword = ""
            
            Application.DisplayAlerts = False
            wb.SaveAs Filename:=currentFilePath, FileFormat:=xlExcel8, Password:="", WriteResPassword:=""
            Application.DisplayAlerts = True
            
            wb.Close SaveChanges:=False
            Set wb = Nothing
        
        Else
            Debug.Print "Dosya açılamadı veya parola yanlış: " & fileName
            On Error GoTo 0
        End If
        
        fileName = Dir
    Loop
    
    MsgBox "Tüm .xls dosyalarının toplu şifre kaldırma işlemi tamamlandı.", vbInformation

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub