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
274

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"
Son Düzenleme: 08/06/2020, 16:53, Düzenleyen: feraz.
Cevapla
#3
Sn@feraz kodu uyguladim ama bir sey degismedi.

Visual Basic Code
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:D15").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("D3:D15").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 Adlı Kullanıcıdan Alıntı: Sn@feraz kodu uyguladim ama bir sey degismedi.

Visual Basic Code
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:D15").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("D3:D15").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
Son Düzenleme: 08/06/2020, 17:26, Düzenleyen: feraz.
Cevapla
#5
(08/06/2020 17:24)feraz Adlı Kullanıcıdan Alıntı:
(08/06/2020 17:18)Oğuz Türkyılmaz Adlı Kullanıcıdan Alıntı: Sn@feraz kodu uyguladim ama bir sey degismedi.

Visual Basic Code
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:D15").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("D3:D15").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 Adlı Kullanıcıdan Alıntı:
(08/06/2020 17:24)feraz Adlı Kullanıcıdan Alıntı:
(08/06/2020 17:18)Oğuz Türkyılmaz Adlı Kullanıcıdan Alıntı: Sn@feraz kodu uyguladim ama bir sey degismedi.

Visual Basic Code
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:D15").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("D3:D15").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