Sayfalar Arası Veri Aktarmak

[wishm]

Değerli site üyeleri ekte gönderdiğim gibi bir excel dosyam var ve bu excel dosyasındaki sayfa1' den sayfa2' ye veri aktarmak istiyorum. Ancak bu verileri aktarırken sadece hücre değerlerini aktarmak istiyorum hücre biçimlerini değil. Bu konuda yardımcı olabilirseniz memnun olurum. Saygılarımla.

 

[Orion1]

Dosyanız ektedir.

Private Sub CommandButton1_Click()
Dim i As Long, sat As Long
sat = Sheets("Sayfa2").Cells(65536, "A").End(xlUp).Row + 1
If sat >= 65533 Then
    MsgBox "Sayfa2 de satır doldu.Başka kayıt giremezsiniz.", vbCritical, "UYARI"
    Exit Sub
End If
For i = 1 To 3
    Sheets("Sayfa2").Cells(sat, i).Value = Cells(i, "A").Value
Next
MsgBox "İşlem tamadır." & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[wishm]

Sayın Evren Gizlen yanıtınız için teşekkür ederim. Tam istediğim şekliyle yanıtlamışsınız. Tekrar teşekkür ederim. Saygılarımla.

 

[Orion1]

Sayın Evren Gizlen yanıtınız için teşekkür ederim. Tam istediğim şekliyle yanıtlamışsınız. Tekrar teşekkür ederim. Saygılarımla.

Rica ederim.
İyi çalışmalar.

 

[tombkiller]

İstedigin kod bu olabilir mi

Sayın Evren Gizlen yanıtınız için teşekkür ederim. Tam istediğim şekliyle yanıtlamışsınız. Tekrar teşekkür ederim. Saygılarımla.

Sanırım istediginiz kod bu.
Deneme1,2,3 'ün yanındaki satırlara veri girip, kırmızı kutuya tıkladığımızda sayfa 2 ye kayıt yapıyor. İstedigin sey tam olarak bu degilse bana msj yaz yardımcı olmaya calısayım.

 

[wishm]

Değerli arkadaşlar sayın Evren Gizlen' in konuyla ilgili vermiş olduğu cevap işime yaradı. Ancak çalışmamı biraz daha geliştirdim ve şu aşamada ekte gönderdiğim dosyadaki gibi bir formdan diğer sayfaya veri aktarmak istiyorum. Sayın Evren Gizlen' in kodlarını bu formata uygulayamadım. Bu konuda yardımcı olabilirseniz memnun olurum. Saygılarımla.

 

[Orion1]

Değerli arkadaşlar sayın Evren Gizlen' in konuyla ilgili vermiş olduğu cevap işime yaradı. Ancak çalışmamı biraz daha geliştirdim ve şu aşamada ekte gönderdiğim dosyadaki gibi bir formdan diğer sayfaya veri aktarmak istiyorum. Sayın Evren Gizlen' in kodlarını bu formata uygulayamadım. Bu konuda yardımcı olabilirseniz memnun olurum. Saygılarımla.

Dosyanız ektedir.

Sub aktar()
Dim sh2 As Worksheet, sh3 As Worksheet, sat As Long
Dim sat1 As Long, sat2 As Long, i As Long, sut As Byte
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh2 = Sheets("Sayfa2")
Set sh3 = Sheets("Sayfa3")
sat = Cells(65536, "A").End(xlUp).Row
sat1 = sh2.Cells(65536, "A").End(xlUp).Row + 1
sat2 = sh3.Cells(65536, "A").End(xlUp).Row
If sat1 + 2 >= 65533 Then
    MsgBox "Sayfa2'de satır doldu.işle4m iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
If sat2 + (sat / 2) >= 65533 Then
    MsgBox "Sayfa3 te satır hepsini lamayacağı için işlem iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
sut = 1
For i = 1 To sat Step 2
    sh2.Cells(sat1, sut).Value = Cells(i, "A").Value
    sh2.Cells(sat1 + 1, sut).Value = Cells(i, "C").Value
    sut = sut + 1
    sh3.Cells(sat2, "A").Value = Cells(i, "C").Value
    sat2 = sat2 + 1
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[wishm]

Sayın Evren Gizlen yanıtınız için teşekkür ederim. Sanırım ifade ederken eksik ifade ettim beim istemiş olduğum tam olarak şu;

Sadece Sayfa1' deki "C1, C3, C5, C7, C9, C11, C13, C15, C17, C19, C21, C23" teki verileri Sayfa2' de "A2, B2, C2, D2, E2, F2, G2, H2, I2, J2, K2, L2" ye aktarmak istiyorum. Yeni veri kaydınıda bir alt satıra yapmak istiyorum. İlginiz ve yanıtınız için şimdiden teşekkür ederim. Saygılarımla.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KAYDET()
    Dim S1 As Worksheet, S2 As Worksheet, X As Byte, Satır As Long, Sütun As Byte
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    Satır = S2.Range("A65536").End(3).Row + 1
    Sütun = 1
 
    For X = 1 To 23 Step 2
        S2.Cells(Satır, Sütun) = S1.Cells(X, 3)
        Sütun = Sütun + 1
    Next
 
    S1.Range("C1,C3,C5,C7,C9,C11,C13,C15,C17,C19,C21,C23").ClearContents
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[wishm]

Sayın Korhan Ayhan ilginiz için teşekkür ederim vermiş olduğunuz kodlar işe yarayacak türde ClearContents olayı kodlarda hoşluk yaratmış şahsen etkileyici buldum. Ben Sayın Evren Gizlen' in vermiş olduğu kodları aşağıdaki şekliyle revize ettim ve istediğim gibi çalışıyor. Ancak kod yazma prosedüründe hata yapıp yapmadığım konusunda emin değilim. Sizler bu konuda fikir beyan edersiniz memnun olurum. Saygılarımla.

Sub aktar()
Dim sh2 As Worksheet, sat As Long
Dim sat1 As Long, sat2 As Long, i As Long, sut As Byte
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh2 = Sheets("Sayfa2")
sat = Cells(65536, "A").End(xlUp).Row
sat1 = sh2.Cells(65536, "A").End(xlUp).Row + 1
If sat1 + 2 >= 65533 Then
    MsgBox "Sayfa2'de satır doldu.işle4m iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
If sat2 + (sat / 2) >= 65533 Then
    MsgBox "Sayfa3 te satır hepsini lamayacağı için işlem iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
sut = 1
For i = 1 To sat Step 2
    sh2.Cells(sat1, sut).Value = Cells(i, "C").Value
    sut = sut + 1
    sat2 = sat2 + 1
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Orion1]

Sayın Korhan Ayhan ilginiz için teşekkür ederim vermiş olduğunuz kodlar işe yarayacak türde ClearContents olayı kodlarda hoşluk yaratmış şahsen etkileyici buldum. Ben Sayın Evren Gizlen' in vermiş olduğu kodları aşağıdaki şekliyle revize ettim ve istediğim gibi çalışıyor. Ancak kod yazma prosedüründe hata yapıp yapmadığım konusunda emin değilim. Sizler bu konuda fikir beyan edersiniz memnun olurum. Saygılarımla.

Sub aktar()
Dim sh2 As Worksheet, sat As Long
Dim sat1 As Long, sat2 As Long, i As Long, sut As Byte
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh2 = Sheets("Sayfa2")
sat = Cells(65536, "A").End(xlUp).Row
sat1 = sh2.Cells(65536, "A").End(xlUp).Row + 1
If sat1 + 2 >= 65533 Then
    MsgBox "Sayfa2'de satır doldu.işle4m iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
If sat2 + (sat / 2) >= 65533 Then
    MsgBox "Sayfa3 te satır hepsini lamayacağı için işlem iptal edildi.", vbCritical, "UYARI"
    Exit Sub
End If
sut = 1
For i = 1 To sat Step 2
    sh2.Cells(sat1, sut).Value = Cells(i, "C").Value
    sut = sut + 1
    sat2 = sat2 + 1
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

Çalıştırıp deneyiniz.
Kodlar hata vermiyorsa ve istediğiniz sonucu veriyorsa doğrudur.