Aynı Buton İle Veri Silme ve Kopyalama

[ormann]

İyi günler ,
Excel dosyamda a1 ve a2 isimli iki sayfam var.A2 sayfasındaki bir butonla önce a1 sayfasındaki tüm verileri silip daha sonra A2 sayfasında A12:M hücre aralığındaki dolu hücreleri a1 sayfasında A2:M hücre aralığına değer olarak makro kopyalamak istiyorum.Nasıl bir makro uygulamalıyım.Yardımcı olur musunuz?

 

[ormann]

Arkadaşlar konu ile ilgili yardımcı olur musunuz?

 

[yanginci34]

aşağıdaki link e örnek dosya yükleyin bakalım
http://s7.dosya.tc/

 

[yanginci34]

aşağıdaki dosyayı bir denermisiniz.
http://s7.dosya.tc/server4/emdc76/kopya_ve_sil.rar.html

 

[ormann]

Çok teşekkür ederim.Ellerinize sağlık.Kopyalama yapmadan önce aktarmak istiyormusunuz.Evet hayır diye bir uyarı verebilir mi?

 

[yanginci34]

Denermisiniz
http://s7.dosya.tc/server4/ub600m/kopya_ve_sil2.rar.html

 

[yanginci34]

Link tekrar güncellenmiştir

 

[ormann]

Çok teşekkür ederim.Kod güzel çalışıyor.Fakat tüm verileri değer olarak kopyalaması gerekiyor.Oysa kod biçimlendirmeleri bile kopyalıyor(sütün satır biçimlenirmesi,çizgi,renk gibi) sadece hücre içerisindeki veriler değer olarak kopyalanacak.Kodu bu şekilde rica etsem revize edermisiniz

 

[yanginci34]

Kırmızı olan yerleri aşağıdaki gibi yapın öyle deneyin.

Sub aktar()
Dim Onay
Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Satir As Long
 Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
Set S1 = Sheets("a2")
    Set S2 = Sheets("a1")
     Onay = MsgBox("aktarmak istediğinize emin misiniz?", vbCritical + vbYesNo)
        If Onay = vbNo Then Exit Sub
    S2.Range("A2:m" & S2.Rows.Count).Clear
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 2
    
       
    
    For X = 12 To Son
    
        
            S1.Range("A" & X & ":m" & X).Copy
            S2.Range("a" & Satir).[COLOR="Red"]PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False[/COLOR]           S2.Range("a" & Satir).[COLOR="Red"]PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False[/COLOR]            
            S1.Cells(X, 14).Copy S2.Cells(Satir, 14)
            Satir = Satir + 1
      
   Next
   
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation

End Sub

 

[ormann]

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

 

[yanginci34]

Rica ederim iyi günler