aktar butonla

[asilme]

arkadaşlar sayfa1 deki A1 hücresinden H60 hücre aralığını sayfa2 ye aktarmak istiyorum.sayfa1 i her aktar dediğimde sayfa2 deki son değerin altına kaydedilerek devam etmesi gerekiyor.siteyi inceledim aktar hakkında çok konu var ancak benimki ile aynı özelliği taşıyanı bulamadım bilgim aşırı olmadığından değiştirip uygulayamıyorum. dosya ekledim mümkünse yardımcı olurmusunuz.not: daha önce sormuştum fakat mesajımı bulamıyorum tekrar sormak zorunda kaldım siz değerli üstatlarımdan yardım bekliyorum.hatta mümkünse ne gözüküyorsa aynısı aktarılabilirmi(tablo-biçim gibi)

 

[YUSUF44]

Aşağıdaki kodları bir modüle ekleyip deneyiniz:

Sub Makro1()
    Range("A1:H60").Select
    Selection.Copy
    Sheets("Sayfa2").Select
a = Sheets("sayfa2").Cells(Rows.Count, 2).End(xlUp).Row + 3
If a = 4 Then
    Cells(1, 1).Select
    ActiveSheet.Paste
Else
    Cells(a, 1).Select
    ActiveSheet.Paste
End If
    Application.CutCopyMode = False
    Sheets("sayfa1").Select
    [a1].Select
End Sub

 

[YUSUF44]

Yalnız şöyle bir problem var: Formun metin bölgesinde F3 hücresinde =BUGÜN() formülüyle günün tarihini atmışsınız. Kopyala/yapıştırdan sonra formüller sabit kalacağından, sayfa2'deki her formun tarihi bugün() olacaktır. Yani ayrı ayrı gün gün göremezsiniz. Düzeltmek için ya f3 hücresine elle tarih girmelisiniz ya da kodlarda değişiklik yapmak gerekir.

 

[YUSUF44]

Son duruma göre kodlar şöyle olmalıdır:

Sub Makro1()
    Range("A1:H60").Select
    Selection.Copy
    Sheets("Sayfa2").Select
a = Sheets("sayfa2").Cells(Rows.Count, 2).End(xlUp).Row
If a = 1 Then
    Cells(1, 1).Select
    ActiveSheet.Paste
    [f3] = [f3].Value
Else
    Cells(a + 3, 1).Select
    ActiveSheet.Paste
End If
    Application.CutCopyMode = False
    Cells(a + 5, "f") = Cells(a + 5, "f").Value
    Sheets("sayfa1").Select
    [a1].Select
End Sub

Bir de sayfa2'de sütun genişliklerini düzgün ayarlamak için bir defaya mahsus olmak üzere sayfa1'deki verileri sütunları seçerek kopyalayın ve 2. sayfaya makroyla değil elle yapıştırın.

 

[asilme]

sayın yusuf 44 emeğinize sağlık gerçekten güzel olmuş kodu yükledim çalışıyor.hakkınızı helal edin yorduk sizi.tarih kısmınıda elle yazacağız ancak aktar dediğimizde aktarma yapıldı tekar aktarılsınmı gibi uyarı çıkması mümkünmü

 

[YUSUF44]

Son kodu görmediniz sanıyorum. Son kodda tarih kısmını elle girmenize gerek yok. diğer isteğinizle biraz uğraşayım.

 

[YUSUF44]

Aşağıdaki kodlar tekrar sorma işlemini de yapmaktadır:

Sub Makro1()
10:
    Range("A1:H60").Select
    Selection.Copy
    Sheets("Sayfa2").Select
a = Sheets("sayfa2").Cells(Rows.Count, 2).End(xlUp).Row
If a = 1 Then
    Cells(1, 1).Select
    ActiveSheet.Paste
    [f3] = [f3].Value
Else
    Cells(a + 3, 1).Select
    ActiveSheet.Paste
End If
    Application.CutCopyMode = False
    Cells(a + 5, "f") = Cells(a + 5, "f").Value
    Sheets("sayfa1").Select
    [a1].Select

aktar = MsgBox("Aktarma yapıldı, tekrar aktarılsın mı?", vbYesNo, "Aktar")
If aktar = vbYes Then GoTo 10:

End Sub

Evet dediğinizde tekrar aktarır.

 

[asilme]

yeni gördüm kusura bakmayın gerçekten elinize sağlık aktarınca sayfa2 nin kopyaladığı yeri göstermesi için nasıl bir kod eklemem gerekiyor

 

[YUSUF44]

Zaten sayfa2'de son eklenen kısım seçili olacaktır.

Şu kodla mesajkutusuna son eklenen alanı ve yeni eklenecek alanı da gösterttim:

Sub Makro1()
10:
    Range("A1:H60").Select
    Selection.Copy
    Sheets("Sayfa2").Select
a = Sheets("sayfa2").Cells(Rows.Count, 2).End(xlUp).Row
If a = 1 Then
    Cells(1, 1).Select
    ActiveSheet.Paste
    [f3] = [f3].Value
Else
    Cells(a + 3, 1).Select
    ActiveSheet.Paste
End If
    Application.CutCopyMode = False
    Cells(a + 5, "f") = Cells(a + 5, "f").Value
    Sheets("sayfa1").Select
    [a1].Select

aktar = MsgBox("Aktarma yapıldı, tekrar aktarılsın mı?" & vbLf & vbLf & "Son ekleme yeri : A" & a + 3 & ":H" & a + 62 & vbLf & vbLf & "Yeni eklenecek yer : A" & a + 63 & ":H" & a + 122, vbYesNo, "Aktarma :)")

If aktar = vbYes Then GoTo 10:

End Sub

 

[asilme]

çok teşekkür ederim hakkınızı helal edin sizi epey yorduk

 

[YUSUF44]

bazı değişiklikler yaptım. Son hali şöyledir:

Sub Makro1()
10:
    Range("A1:H60").Select
    Selection.Copy
    Sheets("Sayfa2").Select
a = Sheets("sayfa2").Cells(Rows.Count, 2).End(xlUp).Row
If a = 1 Then
    Cells(1, 1).Select
    ActiveSheet.Paste
    [f3] = [f3].Value
    aktar1 = MsgBox("Aktarma yapıldı, tekrar aktarılsın mı?" & vbLf & vbLf & "Son ekleme yeri : A1:H60" & vbLf & vbLf & "Yeni eklenecek yer : A61:H120", vbYesNo, "Aktar")
    Application.CutCopyMode = False
    Sheets("sayfa1").Select
    [a1].Select
    If aktar1 = vbYes Then GoTo 10:
    If aktar1 = vbNo Then GoTo son:
Else
    Cells(a + 3, 1).Select
    ActiveSheet.Paste
End If
    Application.CutCopyMode = False
    Cells(a + 5, "f") = Cells(a + 5, "f").Value
    Sheets("sayfa1").Select
    [a1].Select

aktar = MsgBox("Aktarma yapıldı, tekrar aktarılsın mı?" & vbLf & vbLf & "Son ekleme yeri : A" & a + 3 & ":H" & a + 62 & vbLf & vbLf & "Yeni eklenecek yer : A" & a + 63 & ":H" & a + 122, vbYesNo, "Aktar")
If aktar = vbYes Then GoTo 10:
son:
End Sub