Makro Kullanarak Verilerin Gönderildiği Sayfadaki Formüller Nasıl Korunur.

1 2
08/06/2020, 19:48

Oğuz Türkyılmaz

(08/06/2020, 19:23)feraz yazdı:
(08/06/2020, 18:21)Oğuz Türkyılmaz yazdı:
(08/06/2020, 17:24)feraz yazdı:
(08/06/2020, 17:18)Oğuz Türkyılmaz yazdı: Sn@feraz kodu uyguladim ama bir sey degismedi.
Sub YeniKayýt()

    Dim ÖrnekDosya, YeniDosya, Firma As Variant
    Dim kitap As Workbook
    Dim syfYeni As Worksheet
    Dim syfFirmalar As Worksheet
    Const syfÖzet As String = "Özet"
  
    Set syfYeni = ThisWorkbook.Sheets("YeniKayýt")
    Set syfFirmalar = ThisWorkbook.Sheets("Firmalar")
    With syfFirmalar
        .Unprotect
        .Cells.Locked = True
    End With
  

  
    Application.ScreenUpdating = False
 
    ' Tanymlamalar
  
    With syfYeni.Range("D3")
        If .Value = "" Then
            syfYeni.Select
            .Select
            MsgBox "Müsteri Adi kismi bos olamaz..", vbCritical, "Hata"
            GoTo son
        End If
       Firma = .Value
    End With
  
    ÖrnekDosya = ActiveWorkbook.Path & "\Örnek.xlsx"
    YeniDosya = ActiveWorkbook.Path & "\" & Firma & ".xlsx"
  
    ' Dosya Kopyala
  
    FileCopy ÖrnekDosya, YeniDosya
  
    ' Listedeki Bilgileri Kopyala
  
    syfYeni.Range("D3   
    ' Yeni Dosyayy Aç
  
    Set kitap = Workbooks.Open(YeniDosya)
  
    With kitap
        .Worksheets(syfÖzet).Select
        .Worksheets(syfÖzet).Range("D3").PasteSpecial xlPasteValues
        .Worksheets(syfÖzet).Range("D3").Select
    End With
    Application.CutCopyMode = False
  
    ActiveWorkbook.Save
    ActiveWindow.Close
  
    With syfFirmalar
        .Select
        If WorksheetFunction.CountA(.Range("A4:A" & Rows.Count)) = 0 Then
            .Rows("1:1").Copy .Range("A4")
            .Rows(4).Replace What:="Örnek", Replacement:=Firma, LookAt:=xlPart
        Else
            .Rows("1:1").Copy .Range("A" & Rows.Count).End(3)(2, 1)
            satir = .Range("A" & Rows.Count).End(3).Row
            .Rows(satir).Replace What:="Örnek", Replacement:=Firma, LookAt:=xlPart
        End If
           .Range("A" & Rows.Count).End(3)(2, 1).Select
    End With
  
    With syfYeni
        .Select
        .Range("D3         .Range("D3").Select
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Ýþlem Tamamlandý.Kayýt Baþarýyla Gerçekleþtirildi"
son:

    Set kitap = Nothing
    Set syfYeni = Nothing
    Set syfFirmalar = Nothing
   
    With syfFirmalar
        .Protect
   End With
   
End Sub
İlgili sayfaya sağ tıklayın sayfayı koru seçin ve ilk iki işaretli olsun.

Dediğim kodu son: yazanın hemen altına ekleyecektiniz
Ben sayfanın sonuna anlamışım Özür . Halloldu teşekkür ederim.
Rica ederim.Normalde biraz daha geliştirilebilir lakin bence gerek yok sonuçta formüller karantina altında şimdi
08/06/2020, 19:55

feraz

With
syfFirmalar

Yerine

With
Activesheet

Yazarsanız kod çalışınca aktif sayfayı korur.

Aslında tam anlamadım tam dediğinizi.
08/06/2020, 20:25

feraz

Formülleri gizlemek içinde alttaki gibi kullanabilirsiniz.

   With syfFirmalar
        .Cells.FormulaHidden = True
        .Protect
   End With

İlgili kodları alttaki gibi yaparsanız şifrelenmiş olur.

With syfFirmalar
        .Unprotect "12345"
        .Cells.Locked = True
    End With


With syfFirmalar
        .Cells.FormulaHidden = True
        .Protect "12345"
    End With
10/06/2020, 07:56

Oğuz Türkyılmaz

(08/06/2020, 19:55)feraz yazdı: With
syfFirmalar

Yerine

With
Activesheet

Yazarsanız kod çalışınca aktif sayfayı korur.

Aslında tam anlamadım tam dediğinizi.
Sn.@ferazBugün deneyip dönüş yaparım. Çok Teşekkür ederim.
1 2