Soru Birden çok Excel kitabı aynı şifre ile tek seferde açılış şifresini kaldırma

[By.TRabZonLutm]

Birden fazla excel kitabı var. Ana klasör ve alt klasörlerden oluşuyor. Tek seferde tümünden açılış şifresini nasıl kaldırabilirim? Şifre aynı 1234. Aynı şekilde tümüne nasıl şifre koyabilirim.

Bu işlemin nedeni klasörde arama yaptığımda Excel dosyaları şifreli olduğu için içerisindeki verileri bulmuyor

 

[By.TRabZonLutm]

Yok mu çözümü. Excel dosyalarını tek tek açıp şifrelerini kaldırmam çok zaman alacak ..

 

[halit3]

acma parolası için

Sub dosla_ac()

On Error Resume Next
Dim dosya
Dim wb As Workbook
On Error Resume Next
Application.DisplayAlerts = False
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", &H4, "")
pth = ObjFolder.Items.Item.Path

acma_paralası = 12
degistirme_parolası = 13

ChDir (pth)
dosya = Dir("*.x**")
While dosya <> ""
Set wb = Workbooks.Open(pth & "\" & dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=pth & "\" & dosya, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False
Wend
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub

şifre değiştirme parolası için

Sub dosya_sifre_koy()

On Error Resume Next
Dim dosya
Dim wb As Workbook

Application.DisplayAlerts = False
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", &H4, "")
pth = ObjFolder.Items.Item.Path


acma_paralası = 12
degistirme_parolası = 13

yeni_acma_paralası = 14
yeni_degistirme_parolası = 15


ChDir (pth)
dosya = Dir("*.x**")
While dosya <> ""
Set wb = Workbooks.Open(pth & "\" & dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=pth & "\" & dosya, _
FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False
Wend
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[Korhan Ayhan]

Merhaba,

Bende bir dosya hazırlamıştım. Arşivde bulunması açısından paylaşıyorum.

 

[By.TRabZonLutm]

acma parolası için

Sub dosla_ac()

On Error Resume Next
Dim dosya
Dim wb As Workbook
On Error Resume Next
Application.DisplayAlerts = False
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", &H4, "")
pth = ObjFolder.Items.Item.Path

acma_paralası = 12
degistirme_parolası = 13

ChDir (pth)
dosya = Dir("*.x**")
While dosya <> ""
Set wb = Workbooks.Open(pth & "\" & dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=pth & "\" & dosya, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False
Wend
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub

şifre değiştirme parolası için

Sub dosya_sifre_koy()

On Error Resume Next
Dim dosya
Dim wb As Workbook

Application.DisplayAlerts = False
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", &H4, "")
pth = ObjFolder.Items.Item.Path


acma_paralası = 12
degistirme_parolası = 13

yeni_acma_paralası = 14
yeni_degistirme_parolası = 15


ChDir (pth)
dosya = Dir("*.x**")
While dosya <> ""
Set wb = Workbooks.Open(pth & "\" & dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=pth & "\" & dosya, _
FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False
Wend
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

Hocam üstteki kodu denedim ama dosya açarken uzantı değiştirilmiş gibi birşey diyordu
File format bölümünü xlOpenXMLWorkbook olarak değiştirdim. Sorun çözüldü. Fakat; tek klasörü secebiliyorum. Bir klasörü seçip alttaki klasörleri de kapsayacak şekilde nasıl yapabilirim

Düzeltme: dosyalarda dış kaynaktan veri var ise güncelleşti - güncelleştirme diye uyarı çıkıyor. Her seferinde çarpı ile kapatmak zorunda kalıyorum bu sefer kasmaya başlıyor. Elle şifreleri daha hızlı kaldırırım fakat dosya çok fazla. bu uyarıyı vermeden nasıl kaldırabilirim

 

[By.TRabZonLutm]

Merhaba,

Bende bir dosya hazırlamıştım. Arşivde bulunması açısından paylaşıyorum.

Hocam sizin dosyada da bu şekilde şifreyi kaldırırken Excel dosyalarını açıyor. Çarpı ile kapatıyorum ama zaman alıyor. Bu ekranı hiç uğraşmadan kapatamaz mıyız

 

[halit3]

cevabı çok geç yazmışsınız.
kodların başına ve sonlarına bunları ekleyin öyle deneyiniz.

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

.......kodlarınız ................

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

 

[halit3]

Sub dosla_ac2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


Liste1 (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste1(yol As String)
On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If

acma_paralası = 12
degistirme_parolası = 13

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close False

End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

Sub dosya_sifre_koy2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


Liste (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If


acma_paralası = 12
degistirme_parolası = 13
yeni_acma_paralası = 14
yeni_degistirme_parolası = 15

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close False
End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

 

[By.TRabZonLutm]

Sub dosla_ac2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


Liste1 (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste1(yol As String)
On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If

acma_paralası = 12
degistirme_parolası = 13

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False

wb.Close
End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

Sub dosya_sifre_koy2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


Liste (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If


acma_paralası = 12
degistirme_parolası = 13
yeni_acma_paralası = 14
yeni_degistirme_parolası = 15

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False
dosya = Dir
wb.Close False

wb.Close
End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

Hocam makro çalıştırdığımda yine bu ekran geliyor

 

[halit3]

Birde bu kodları dene

Sub dosla_ac2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False

End With


Liste1 (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste1(yol As String)
'On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If

acma_paralası = 12
degistirme_parolası = 13

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

wb.Close False

End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub




Sub dosya_sifre_koy2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With


Liste (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
'On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If


acma_paralası = 12
degistirme_parolası = 13
yeni_acma_paralası = 14
yeni_degistirme_parolası = 15

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False

wb.Close False

End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

 

[By.TRabZonLutm]

Birde bu kodları dene

Sub dosla_ac2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False

End With


Liste1 (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste1(yol As String)
'On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If

acma_paralası = 12
degistirme_parolası = 13

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

wb.Close False

End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub




Sub dosya_sifre_koy2()

sayfaadi = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With


Liste (Kaynak)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
'On Error Resume Next
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each dosya In fs.GetFolder(yol).Files
uzanti = fs.GetExtensionName(dosya.Name)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If


acma_paralası = 12
degistirme_parolası = 13
yeni_acma_paralası = 14
yeni_degistirme_parolası = 15

If ThisWorkbook.Name <> dosya.Name Then
If Mid(dosya.Name, 1, 2) <> "~$" Then
Set wb = Workbooks.Open(dosya, Password:=acma_paralası, WriteResPassword:=degistirme_parolası)
Application.DisplayAlerts = False

wb.SaveAs Filename:=dosya, FileFormat:=xlNormal, Password:=yeni_acma_paralası, WriteResPassword:=yeni_degistirme_parolası, _
ReadOnlyRecommended:=False, CreateBackup:=False

wb.Close False

End If
End If
Dir dosya
atla:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

Çok teşekkürler. Sorunsuz çalışıyor. Merak ettiğim için soruyorum, bunların farkı nedir?
Açma parolası mevcut olan şifreyi kaldırmak için, yeni açma parolası da sıfırdan şifre koymak için , değiştirme parolası ve yeni değiştirme parolası nedir
acma_paralası = 12
degistirme_parolası = 13
yeni_acma_paralası = 14
yeni_degistirme_parolası = 15

 

[halit3]

Sorunun devamında parolanın değişeceğini düşünerek kodları yazmıştım.

 

[Korhan Ayhan]

Paylaştığım dosyada küçük bir revize yaptım. Tekrar deneyiniz.