Sütunlardaki verileri aktarma

[hatirlabeni]

Arkadaşlar kolay gelsin

A B C ve K sütunlarındaki verileri makro ile buton atayarak T.Çal.Gün.Sayısı sayfasına aktarmasını nasıl sağlayabilirim ?

Dosya ekte.

 

[Murat OSMA]

Şu kodları kullanabilirsiniz;

Sub Emre()
    Dim i As Integer
    Application.ScreenUpdating = False
    For i = 2 To Range("B65536").End(3).Row
        Cells(i, 1).Resize(, 3).Copy
        Sayfa1.Range("A65536").End(3)(2, 1).PasteSpecial xlValues
        Cells(i, "K").Copy
        Sayfa1.Range("D65536").End(3)(2, 1).PasteSpecial xlValues
    Next i
    Sayfa1.Columns.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[hatirlabeni]

Hocam Elinize Sağlık

Buna ek olarak hücreleri başlıkları ile alsak ve renklerde dahil olsa ve aktarma sonunda mesaj verse.

 

[Murat OSMA]

Şu kodları deneyiniz;

Sub Emre()
    Dim i As Integer
    Application.ScreenUpdating = False
    With Sayfa7
        .Range("A1:C1").Copy Sayfa1.Range("A1")
        .Range("K1").Copy Sayfa1.Range("D1")
    For i = 2 To .Range("B65536").End(3).Row
        .Cells(i, 1).Resize(, 3).Copy Sayfa1.Range("A65536").End(3)(2, 1)
        .Cells(i, "K").Copy Sayfa1.Range("D65536").End(3)(2, 1)
    Next i
    End With
    Sayfa1.Columns.AutoFit
    Sayfa1.Rows("1:1").RowHeight = 39
    Sayfa1.Columns("C:C").ColumnWidth = 17.5
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "..::.. Aktarıldı ..::.."
End Sub

 

[hatirlabeni]

Hocam yapılabilir mi ?

 

[Murat OSMA]

Sonuç nedir ? :dusun:

 

[hatirlabeni]

Hocam Aktarma tam istedigim gibi fakat K sütununu aktarınca aktarma işlemini #BAŞV! olarak hatalı yazıyor nedeni hücrede formul olmasından mı kaynaklanıyor ?

 

[Murat OSMA]

Evet K sütununda formül olduğu için...

Şu şekilde bir deneyiniz;

Sub Emre()
    Dim i As Integer
    Application.ScreenUpdating = False
    With Sayfa7
        .Range("A1:C1").Copy Sayfa1.Range("A1")
        .Range("K1").Copy Sayfa1.Range("D1")
    For i = 2 To .Range("B65536").End(3).Row
        .Cells(i, 1).Resize(, 3).Copy Sayfa1.Range("A65536").End(3)(2, 1)
        .Cells(i, "K").Copy
        Sayfa1.Range("D65536").End(3)(2, 1).PasteSpecial xlValues
        Sayfa1.Cells(i, "D").Interior.ColorIndex = 3
    Next i
    End With
    Sayfa1.Columns.AutoFit
    Sayfa1.Rows("1:1").RowHeight = 39
    Sayfa1.Columns("C:C").ColumnWidth = 17.5
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "..::.. Aktarıldı ..::.."
End Sub