Skip to main content

AccessTr.neT


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

Oğuz Türkyılmaz
Oğuz Türkyılmaz
9
1131

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

Çözüldü #1
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
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
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
(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
(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
(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