Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

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

Oğuz Türkyılmaz
Oğuz Türkyılmaz
Excel Cevaplanmış Soruları
9
1333

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

Çözüldü #1
Oğuz Türkyılmaz
Aktif Üye
Oğuz Türkyılmaz
Bul
Aktif Üye
Adı Soyadı: Oğ.... Tü....
Yaşı: 56
Konum: Antalya
Ofis Versiyonu: Ofis 2019 64 Bit
Son Oturumu: 03/05/2023,09:23
Yorumları: 1.583
Konuları: 265
Kayıt Tarihi: 08/02/2018
Teşekkür Puanı: 0
Mesleğiniz: İşletmeci
Merhaba

Makro ile Açtığım Müşteri kartı bilgilerini Müşteri listesi adlı bir sayfaya satır satır atıyorum. Müşteri listesi sayfasındaki formüllerin bozulmaması için sayfayı korumaya aldığımda makro çalıştığında sayfa korumalı olduğu için kaydı sayfaya ekleyemiyor. Sadece eklenen mevcut satırlardaki hücreleri korumaya alsam sorunu mevcutlar için engellerim ama bu seferde her yeni müşteri kaydında tekrardan sayfa korumasını kaldırıp yeni korunacak alanı tekrardan belirtmem gerekecek. Bu süreci bu şekilde uzatmadan çözmenin bir yolu var mı. Yol göstermenizi rica ederim.

[Resim: do.php?img=10308]
Access Çekirgesi 
[Resim: img-cray.gif]


Cevapla
#2
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: 28/07/2024,00:46
Yorumları: 3.642
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
Set syfFirmalar = ThisWorkbook.Sheets("Firmalar") bu kod satırının altına
     
Kod:
With syfFirmalar
        .Unprotect
        .Cells.Locked = True
    End With
son: kod satırının altına alttakini ekleyin.Firma eklenince çalışır.

Kod:
With syfFirmalar
        .Protect
   End With
Şifreli olsun derseniz alttaki hibi deneyin.

Unprotect "şifre"
protect "şifre"
Cevapla
#3
Oğuz Türkyılmaz
Aktif Üye
Oğuz Türkyılmaz
Bul
Aktif Üye
Adı Soyadı: Oğ.... Tü....
Yaşı: 56
Konum: Antalya
Ofis Versiyonu: Ofis 2019 64 Bit
Son Oturumu: 03/05/2023,09:23
Yorumları: 1.583
Konuları: 265
Kayıt Tarihi: 08/02/2018
Teşekkür Puanı: 0
Mesleğiniz: İşletmeci
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("D3Lol15").Copy

   

    ' 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("D3Lol15").ClearContents

        .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
.rar CariTakipMaster.rar (Dosya Boyutu: 213,25 KB | İndirme Sayısı: 0)
Access Çekirgesi 
[Resim: img-cray.gif]


Cevapla
#4
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: 28/07/2024,00:46
Yorumları: 3.642
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
(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("D3Lol15").Copy

   

    ' 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("D3Lol15").ClearContents

        .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
Cevapla
#5
Oğuz Türkyılmaz
Aktif Üye
Oğuz Türkyılmaz
Bul
Aktif Üye
Adı Soyadı: Oğ.... Tü....
Yaşı: 56
Konum: Antalya
Ofis Versiyonu: Ofis 2019 64 Bit
Son Oturumu: 03/05/2023,09:23
Yorumları: 1.583
Konuları: 265
Kayıt Tarihi: 08/02/2018
Teşekkür Puanı: 0
Mesleğiniz: İşletmeci
(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("D3Lol15").Copy

   

    ' 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("D3Lol15").ClearContents

        .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.
Access Çekirgesi 
[Resim: img-cray.gif]


Cevapla
#6
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: 28/07/2024,00:46
Yorumları: 3.642
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
(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("D3Lol15").Copy

   

    ' 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("D3Lol15").ClearContents

        .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 Img-grin
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task