Makro ile farklı kayıt edip bağlantıları kesme

**#1)** **teyadih** » 07 Mar 2023 22:09

Merhaba arkadaşlar.
D:\PAYLAŞIM\BELGELER\1.PERSONEL\İZİNLER\1.YILLIK İZİN klasöründe bulunan YILLIK İZİN TAKİP dosyasındaki Açıklama sayfası Z1 deki Farklı Kaydet düğmesine tıkladığımda söz konusu dosyayı YILLIK İZİN TAKİP 2022 şeklinde bir önceki yıl ismi ile aynı klasörün içine farklı kayıt edecek ve farklı kayıt ettikten sonra
Bilgiler sayfası D1 ve D2 deki formülleri DEĞER olarak yapıştırıp, Veri/Bağlantıları Düzenle sekmesinde bulunan
Hakim ve Personel Listesi Yeni Liste
A-UYAP'tan Çekilen Bilgiler
B-Kullanılan İzinler
Terfi Listesi
dosyalarının bağlantılarını kesecek bir makroya ihtiyacım var.
Farklı kaydetmek için düğmeye tıkladığımda Farklı Kayıt Edilsin Mi? uyarısı vermesi, sehven farklı kayıt etme ihtimaline karşı Hayır seçeneğinin seçili gelmesi, Evet seçeneğini tıkladığımda ise birde şifre istemesi ve şifre girip öyle işlem yapılabilirse riski sıfırlamış oluruz.
Çalışma kitabındaki sayfa koruması şifresi 7895123 Umarım anlatabilmişimdir.
Teşekkür ederim

https://www.dosya.tc/server41/s8t2d5/PAYLASIM.zip.html

**#2)** **Yken** » 08 Mar 2023 19:17

Kod: Tümünü seç: Sub Farkli_Kaydet() Dim i As Integer, a As Variant Const sifre As String = "1234" sor = MsgBox("Farklı Kayıt Edilsin Mi?" & vbCrLf & "Harici Bağlantıları kaldırılacak" & vbCrLf & "Bu İşlemler Yapılsın mı..?", _ vbQuestion + vbDefaultButton2 + vbYesNo, "Bilgi Mesajı") If sor = vbNo Then Exit Sub a = InputBox("Şifreyi girin!", "Şifre Giriş Ekranı") Do While a <> sifre And a <> vbNullString MsgBox "Lütfen Şifreyi Doğru giriniz..!", vbCritical a = InputBox("Şifreyi girin!", "Şifre Giriş Ekranı") Loop If a = vbNullString Then Exit Sub Application.Calculation = xlManual Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next For i = 1 To Sheets.Count Sheets(i).Unprotect "7895123" With ActiveWorkbook For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks) .BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks Next End With Next i Sheets("Bilgiler").Range("D1:D2").Value = Sheets("Bilgiler").Range("D1:D2").Value Application.CalculateBeforeSave = False Application.AskToUpdateLinks = True Application.DisplayAlerts = False ThisWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & _ Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, Chr(46)) - 1) & " " & Format(Date, "yyyy") - 1, FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True Application.AskToUpdateLinks = False Application.CalculateBeforeSave = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True Sheets(1).Select MsgBox "Belgeniz farklı kaydedildi, dış bağlantılar iptal edildi", vbInformation End Sub

**#3)** **teyadih** » 08 Mar 2023 20:39

Teşekkür ederim sayın Yken uygulayıp dönüş yapacağım

**#4)** **teyadih** » 09 Mar 2023 12:30

Teşekkür ederim sayın Yeken kod tamam elinize sağlık. Kod çalıştığında sadece farklı kayıt edilen dosya açık kalıyor sayın Yken.
Mevcut açık dosyanın bağlantılarını kesip ismini değiştirerek işlem yapıyor sanırım.
doğru mu? anladım