Verileri datadan listeye kaydetme

[bir2üç]

Ekli dosyada "Kayıt" bölümünde yazdıklarımı kaydet butonuyla "liste" bölümüne yazdırmak istiyorum. Makroyu denedim ancak çalışmadı. Ayrıca liste kısmına yazılan bütün verilerin korunmasını istiyorum eğer protect sheet dersem makro çalışır mı? Yardımlarınız için şimdiden teşekkürler

 

[Ömer]

Merhaba,

Sub DataAktar()
Dim s1 As Worksheet, son As Long
Set s1 = Sheets("liste")
son = s1.[B65536].End(3).Row + 1
    s1.Range("A" & son).Value = son - 1
    s1.Range("B" & son).Value = Range("D9").Value
    s1.Range("C" & son).Value = Range("E9").Value
    s1.Range("D" & son).Value = Range("G9").Value
    s1.Range("E" & son).Value = Range("I9").Value
    s1.Range("F" & son).Value = Range("D13").Value
    s1.Range("G" & son & ":O" & son).Value = Range("D16:L16").Value
    s1.Range("P" & son).Value = Range("E19").Value
    s1.Range("Q" & son).Value = Range("F19").Value
    s1.Range("R" & son).Value = Range("H19").Value
    s1.Range("S" & son).Value = Range("J19").Value
Range("D9:L9").ClearContents: Range("D13:L13").ClearContents
Range("D16:L16").ClearContents: Range("E19:K19").ClearContents
s1.Columns("A:S").EntireColumn.AutoFit
End Sub

Bu şekilde kullanın. Gereksiz birleştirmeleri kaldırdım. Gerekmedikçe hücre birleştirmemeye özen gösteriniz.

Eki inceleyiniz..

.

 

[bir2üç]

Çok teşekkür ederim anacak aktar dediğimizde kopyalama işlemini gerçekleştirmiyor.

 

[Ömer]

Çok teşekkür ederim anacak aktar dediğimizde kopyalama işlemini gerçekleştirmiyor.

Haklsınız denemeden yazmıştım. Silme kodlarını ters yerleştirmişim. #2 nolu mesajı güncelledim tekrar denermisiniz..

.

 

[bir2üç]

Çok teşekkür ederim. Ellerinize sağlık

 

[bir2üç]

Dosyayı güncelledim ancak protected sheet olduğu için uyarı verior. "Liste" kısmında yer alan autofilter seçeneklerinin kullanılmasına izin verip başka hiçbir değişime izin vermek istemiyorum "kayıt" bölümünde ise sadece belirttiğim yerlerin kullanılmasını istedim. Ancak protect dediğimde uyarı veriyor. Birde her makro açılışında enable macros seçeneğini kullanmalıyım? Yardımlarınız için teşekkürler.

 

[bir2üç]

Unutmuşum dosyanın koruma şifresi 123456 dır.

 

[Ömer]

Kodları aşağıdakilerle değiştirerek deneyin..

Sub DataAktar()
Dim s1 As Worksheet, son As Long
Set s1 = Sheets("kayıt")
Application.ScreenUpdating = False
Sheets("liste").Select
ActiveSheet.Unprotect 123456
son = [B65536].End(3).Row + 1
    Range("A" & son).Value = son - 1
    Range("B" & son).Value = s1.Range("D9").Value
    Range("C" & son).Value = s1.Range("E9").Value
    Range("D" & son).Value = s1.Range("G9").Value
    Range("E" & son).Value = s1.Range("I9").Value
    Range("F" & son).Value = s1.Range("D13").Value
    Range("G" & son & ":O" & son).Value = s1.Range("D16:L16").Value
    Range("P" & son).Value = s1.Range("E19").Value
    Range("Q" & son).Value = s1.Range("F19").Value
    Range("R" & son).Value = s1.Range("H19").Value
    Range("S" & son).Value = s1.Range("J19").Value
[COLOR=red]s1.Range("D9:L9").ClearContents: s1.Range("D13:L13").ClearContents[/COLOR]
[COLOR=red]s1.Range("D16:L16").ClearContents: s1.Range("E19:K19").ClearContents[/COLOR]
Columns("A:S").EntireColumn.AutoFit
ActiveSheet.Protect 123456
s1.Select
Application.ScreenUpdating = True
End Sub

.

 

[bir2üç]

Sizin göndermiş olduğunuz kod dışında birşey denedim çalıştı ancak örneğin "öneri başlığı" doldurulduğunda eğer kayıt ekranı boşken yanlışlıkla "kaydet" butonuna basıldığında en son yazılan bilgileri siliyor. Konu hakkında yardımlarınızı rica ederim.

 

[Ömer]

Verilerin silinmesini istemiyorsanız #8 nolu mesajda kırmızı ile işaretli bölümü kaldırarak deneyin.

.