aktarılan bilgilerin silinmesi

[fedeal]

Sub AKTAR()
Dim S1, S2 As Worksheet
Dim SUT, S As Integer
Set S1 = Sheets("giriş")
Set S2 = Sheets("MASRAF")
S = 2
For Each DEG In S1.Range("E24,E26,E28,E30,E32,E34,E36,E38,E40,E42,E44,K24,K26,K28,K30,K32,K34,K36,K38,K40,K42,K44,Q24,Q26,Q28,Q30,Q32,Q34,Q36,Q38,Q40,Q42,Q44,B6,B9,B12,E6,E9,E12,H6,H9,H12,K6,K9,K12,N6,N9,N12,Q6,Q9,Q12,C18,O21,Q21,R21,S21")
For SUT = 4 To S2.Cells(65536, "A").End(3).Row
If S1.[G21] = S2.Cells(SUT, "A") Then
S2.Cells(SUT, S) = DEG
S = S + 1
End If
Next
Next
End Sub

yukarıdaki makroyla aktarım yapıyorum benim sorum aktar butonuna bastıkmı aktarılan veri otamatik silinebilirmi.

 

[fedeal]

örnek dosya

örnek dosya ekte

 

[Ayhan Ercan]

Merhaba Sn fedeal

Kodda eklenen yerler kırmızı yazılmıştır. İnceleyiniz...

Dim S1, S2 As Worksheet, [COLOR=red][B]deg As Range[/B][/COLOR]
Dim SUT, S As Integer
Set S1 = Sheets("giriş")
Set S2 = Sheets("MASRAF")
S = 2
    For Each deg In S1.Range("E24,E26,E28,E30,E32,E34,E36,E38,E40,E42,E44,K24,K26,K28,K30,K32,K34,K36,K38,K40,K42,K44,Q24,Q26,Q28,Q30,Q32,Q34,Q36,Q38,Q40,Q42,Q44,B6,B9,B12,E6,E9,E12,H6,H9,H12,K6,K9,K12,N6,N9,N12,Q6,Q9,Q12,C18,O21,Q21,R21,S21")
        For SUT = 4 To S2.Cells(65536, "A").End(3).Row
            If S1.[G21] = S2.Cells(SUT, "A") Then
                S2.Cells(SUT, S) = deg
                S = S + 1
            End If
        Next
    [B][COLOR=red]deg.Value = Empty[/COLOR][/B]
    Next
End Sub

 

[fedeal]

cok tşkürler ayhan bey tam istedigim gibi oldu.emeginize saglık.

 

[Ayhan Ercan]

cok tşkürler ayhan bey tam istedigim gibi oldu.emeniginize saglık.

Rica ederim.
İyi Çalışmalar.. k::