Hücreye eklenen açıklama ile birlikte aktarma

[tahsinanarat]

Ekli dosyada a sutununda başına "x" veya "A" işareti koyduklarımızı Sayfa2'ye aktarabiliyoruz, ancak hücreye eklediğimiz açıklamalar ile birlikte aktarmak istersek kodda ne gibi bir değişiklik yapmalıyız. Cevap için şimdiden teşekkür ederim.

Kod:
Sub aktar()
Sheets("Sayfa1").Select
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A3:K65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "B").End(xlUp).Row
If Cells(i, "A").Value = "A" Or Cells(i, "A").Value = "x" Then
adr1 = Range(Cells(i, "B"), Cells(i, "L")).Address
adr2 = Range(Cells(sat, "A"), Cells(sat, "k")).Address
s2.Range(adr2).Value = Range(adr1).Value
sat = sat + 1
Adet = sat + 1 - 3
End If
Next
Application.ScreenUpdating = True
Set s2 = Nothing
MsgBox " Sayfa2'ye " & Adet & " Adet Kayıt Aktarılmıştır.."
End Sub

 

[N.Ziya Hiçdurmaz]

Yanıt

Kodda düzeltme yaptım deneyiniz.

Sub aktar()
Sheets("Sayfa1").Select
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A3:K65536").Clear
sat = 2
For i = 2 To Cells(65536, "B").End(xlUp).Row
    If Cells(i, "A").Value = "A" Or Cells(i, "A").Value = "x" Then
        adr1 = Range(Cells(i, "B"), Cells(i, "L")).Address
        adr2 = Range(Cells(sat, "A"), Cells(sat, "k")).Address
        Range(adr1).Copy
        s2.Range(adr2).PasteSpecial
        sat = sat + 1
        Adet = sat + 1 - 3

    End If
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set s2 = Nothing
    MsgBox " Sayfa2'ye " & Adet & " Adet Kayıt Aktarılmıştır..T O M S O N!!"
End Sub

 

[tahsinanarat]

Sn. V.Basic For Applications; ilgi ve alakanıza çok teşekkür ederim. sağolun, yeni yılın size uğur getirmesini temenni ederim.

 

[N.Ziya Hiçdurmaz]

Sayın tahsinanarat Sizde sağolun.