Kopyalama Makrosu

[csncesur]

Ekteki Dosyamda A1 hücresindeki veriyi AKTAR butonuna tıkladığım zaman Sayfa 2 deki A1 hücresine kopyalamasını istiyorum. Şimdiden Teşekkürler.

 

[bmutlu966]

Bir modüle ekleyip çalıştırın.

Sub aktar()
Range("A1").Copy
Sheets("Sayfa 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False
End Sub

 

[csncesur]

Bir modüle ekleyip çalıştırın.

Sub aktar()
Range("A1").Copy
Sheets("Sayfa 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False
End Sub

hocam elinize sağlık çok teşekkür ederim

 

[csncesur]

Bir modüle ekleyip çalıştırın.

Sub aktar()
Range("A1").Copy
Sheets("Sayfa 2").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False
End Sub

Hocam bi soru daha soracağım A1 hücresindeki veriyi AKTAR butonuna tıkladığım zaman Sayfa 2 deki A1 hücresine değilde hep bi alttaki en son hücreye nasıl aktarabilirim yardımcı olabilir misiniz

 

[Korhan Ayhan]

Böyle olabilir..

Mükerrer aktarımı engellemekte de fayda var.

Option Explicit

Sub Aktar()
    Dim Sh As Worksheet
    
    Set Sh = Sheets("Sayfa 2")
    
    If WorksheetFunction.CountIf(Sh.Range("A:A"), Range("A1")) > 0 Then
        If MsgBox("Bu veri daha önce aktarılmıştır. Yine de aktarmak istiyor musunuz?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then
            GoTo 20
        Else
            GoTo 10
        End If
    Else
10      If Sh.Range("A1") = "" Then
            Sh.Range("A1") = Range("A1")
        Else
            Sh.Cells(Sh.Rows.Count, 1).End(3)(2, 1) = Range("A1")
        End If
            
        MsgBox "Veri aktarıldı..."
    End If
        
20  Set Sh = Nothing
End Sub

 

[csncesur]

Böyle olabilir..

Mükerrer aktarımı engellemekte de fayda var.

Option Explicit

Sub Aktar()
    Dim Sh As Worksheet
   
    Set Sh = Sheets("Sayfa 2")
   
    If WorksheetFunction.CountIf(Sh.Range("A:A"), Range("A1")) > 0 Then
        If MsgBox("Bu veri daha önce aktarılmıştır. Yine de aktarmak istiyor musunuz?", vbCritical + vbYesNo + vbDefaultButton2) = vbNo Then
            GoTo 20
        Else
            GoTo 10
        End If
    Else
10      If Sh.Range("A1") = "" Then
            Sh.Range("A1") = Range("A1")
        Else
            Sh.Cells(Sh.Rows.Count, 1).End(3)(2, 1) = Range("A1")
        End If
           
        MsgBox "Veri aktarıldı..."
    End If
       
20  Set Sh = Nothing
End Sub

Çok ama çok teşekkür ederim elinize sağlık