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

(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

   With syfFirmalar

        .Cells.FormulaHidden = True

        .Protect

   End With

With syfFirmalar

        .Unprotect "12345"

        .Cells.Locked = True

    End With

With syfFirmalar

        .Cells.FormulaHidden = True

        .Protect "12345"

    End With

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