• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

B

By.TRabZonLutm

Altın Üye
Katılım
15 Aralık 2017
Mesajlar
137
Excel Vers. ve Dili
Excel 2016 - Türkçe
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
 
Son düzenleme:
Yok mu çözümü. Excel dosyalarını tek tek açıp şifrelerini kaldırmam çok zaman alacak ..
 
acma parolası için
PHP: 
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

PHP: 
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
 
Son düzenleme:
halit3' Alıntı:
acma parolası için
PHP: 
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

PHP: 
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
Genişletmek için tıkla ...
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
 
Son düzenleme:
Korhan Ayhan' Alıntı:
Merhaba,

Bende bir dosya hazırlamıştım. Arşivde bulunması açısından paylaşıyorum.
Genişletmek için tıkla ...
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
image.jpg
 
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
 
Kod: 
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

Kod: 
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
 
Son düzenleme:
halit3' Alıntı:
Kod: 
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

Kod: 
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
Genişletmek için tıkla ...
Hocam makro çalıştırdığımda yine bu ekran geliyor
image.jpg
 
Birde bu kodları dene

Kod: 
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
 
halit3' Alıntı:
Birde bu kodları dene

Kod: 
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
Genişletmek için tıkla ...
Ç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
 
Sorunun devamında parolanın değişeceğini düşünerek kodları yazmıştım.
 
Paylaştığım dosyada küçük bir revize yaptım. Tekrar deneyiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst