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