İkinci bir sayfaya Aktarma

[ormann]

İyi günler ekteki örnek dosyada ster sayfasında sarı renkte belirtmiş olduğum veriler "Ebat Listesi Aktar" butonuna bastığımda veriler Ebat Listesi sayfasına aktarılıyor;Benimyapmak istediğim aşağıdaki hücrelerdeki verilerin aynı butonla "ÜST YAZI" sayfasına aktarılmasıdır.Bu konuda yardımlarınızı bekliyorum.Saygılar.

L5-F32
C5-G32
C4-I32
L4-L32
U2-N32
U3-O32

Private Sub CommandButton1_Click()
Dim STR As Long, SR As Variant
Dim SYF As Worksheet
Set SYF = Sheets("EBAT LİSTELERİ")
SR = MsgBox("Kayıt Yapılsın Mı_?", vbYesNo, "SORU")
If SR = vbNo Then Exit Sub
Application.ScreenUpdating = False
STR = SYF.Range("D" & Rows.Count).End(xlUp).Row + 1
SYF.Cells(STR, "D") = Range("C5")
SYF.Cells(STR, "E") = Range("C4")
SYF.Cells(STR, "F") = Range("L4")
SYF.Cells(STR, "G") = Range("L5")
SYF.Cells(STR, "J") = Range("U2")

SYF.Cells(STR, "K") = Range("K68")
SYF.Cells(STR, "L") = Range("P64")
SYF.Range("C7") = 1
SYF.Range("C7:C" & STR).DataSeries xlColumns, xlLinear, xlDay, 1, , False
Application.ScreenUpdating = True
MsgBox Range("E3") & " Verileri Aktarıldı", vbInformation
End Sub

 

[dEdE]

Merhaba,
Mevcut kodu aşağıdaki ile değiştirip dener misiniz?

Private Sub CommandButton1_Click()
Dim STR As Long, SR As Variant
Dim SYF As Worksheet
Dim s1 As Worksheet

Set SYF = Sheets("EBAT LİSTELERİ")
SR = MsgBox("Kayıt Yapılsın Mı_?", vbYesNo, "SORU")
If SR = vbNo Then Exit Sub
Application.ScreenUpdating = False
STR = SYF.Range("D" & Rows.Count).End(xlUp).Row + 1
SYF.Cells(STR, "D") = Range("C5")
SYF.Cells(STR, "E") = Range("C4")
SYF.Cells(STR, "F") = Range("L4")
SYF.Cells(STR, "G") = Range("L5")
SYF.Cells(STR, "J") = Range("U2")

SYF.Cells(STR, "K") = Range("K68")
SYF.Cells(STR, "L") = Range("P64")
SYF.Range("C7") = 1
SYF.Range("C7:C" & STR).DataSeries xlColumns, xlLinear, xlDay, 1, , False
'-------------------eklenen kod----------------------
Set s1 = Sheets("ÜST YAZI")
s1.[F32].Value = [L5].Value
s1.[G32].Value = [C5].Value
s1.[I32].Value = [C4].Value
s1.[L32].Value = [L4].Value
s1.[N32].Value = [U2].Value
s1.[O32].Value = [U3].Value
Application.ScreenUpdating = True
MsgBox Range("E3") & " Verileri Aktarıldı", vbInformation
End Sub

 

[ormann]

Sayın Dede ikinci bir veriyi aktarmak istediğimde üst yazı sayfasında bir alt satıra aktarması gerekirken yine aynı satırın üzerine aktarıyor.

 

[dEdE]

Sayın Dede ikinci bir veriyi aktarmak istediğimde üst yazı sayfasında bir alt satıra aktarması gerekirken yine aynı satırın üzerine aktarıyor.

Merhaba,
İlk mesajınızda istediğinizidikkatle okursanız neden öyle olduğunu anlarsınız. Siz bunu istediniz.

L5-F32
C5-G32
C4-I32
L4-L32
U2-N32
U3-O32

Kod da aynen bunu yapıyor.

Neyse !!! Aşağıdaki kodu kullanabilirsiniz.

Private Sub CommandButton1_Click()
Dim STR, ss As Long, SR As Variant
Dim SYF As Worksheet
Dim s1 As Worksheet

Set SYF = Sheets("EBAT LİSTELERİ")
SR = MsgBox("Kayıt Yapılsın Mı_?", vbYesNo, "SORU")
If SR = vbNo Then Exit Sub
Application.ScreenUpdating = False
STR = SYF.Range("D" & Rows.Count).End(xlUp).Row + 1
SYF.Cells(STR, "D") = Range("C5")
SYF.Cells(STR, "E") = Range("C4")
SYF.Cells(STR, "F") = Range("L4")
SYF.Cells(STR, "G") = Range("L5")
SYF.Cells(STR, "J") = Range("U2")

SYF.Cells(STR, "K") = Range("K68")
SYF.Cells(STR, "L") = Range("P64")
SYF.Range("C7") = 1
SYF.Range("C7:C" & STR).DataSeries xlColumns, xlLinear, xlDay, 1, , False
'-------------------eklenen kod----------------------
Set s1 = Sheets("ÜST YAZI")
ss = s1.[F41].End(xlUp).Row + 1
s1.Cells(ss, "F").Value = [L5].Value
s1.Cells(ss, "G").Value = [C5].Value
s1.Cells(ss, "I").Value = [C4].Value
s1.Cells(ss, "L").Value = [L4].Value
s1.Cells(ss, "N").Value = [U2].Value
s1.Cells(ss, "O").Value = [U3].Value
Application.ScreenUpdating = True
MsgBox Range("E3") & " Verileri Aktarıldı", vbInformation
End Sub

 

[ormann]

Sayın Dede ilgi ve alakanıza çok teşekkür ederim.Üst yazı sayfasındaki F32 hücresinde veri yoksa aktarma işlemi olmuyor.

 

[dEdE]

Merhaba,
Sorun bir üstteki birleştirilmiş hücreden kaynaklanıyor. Aşağıdaki siyah satırın altına kırmızı satırı ilave ederek dener misiniz?

ss = s1.[F41].End(xlUp).Row + 1
[COLOR="Red"]If ss = 31 Then ss = 32[/COLOR]

 

[ormann]

Çok Teşekkür ederim.ellerinize sağlık