Sadece değerleri kopyalayıp aktarma

[mkuru28]

Merhaba arkadaşlar..
Öncelikle foruma yeni üye olduğum için tüm arkadaşlara selamlarımı sunarım.
Arkadaşlar bir çalışma kitabında EXCEL adında bir sayfam var. Bu sayfanın B5:J35 aralığında başka bir sayfadan formüller kullanarak aldığım değerler var. Ancak bazen tamamı doluyor bazen de 3-5 adet veri alıyorum. Aşağıdaki kod ile bu verileri DEFTER sayfasına aktardığım zaman B5:J35 aralığının tamamını aldığı için ikinci kez aktarma yapmam gerektiğinde arada boşluklar oluşuyor. Her seferinde boşluk oluşmaması için hücre değerleri 0 veya "" olan değerleri seçmeden sadece dolu hücreleri seçip aktarması için nasıl bir kod kullanmam gerekir. Kullandığım aktarma fonksiyonu bu

Sheets("EXCEL").Range("B5:J35").Copy
Sheets("DEFTER").Range("B65536").End(xlUp)(2, 1).PasteSpecial xlValues

 

[Muzaffer Ali]

Merhaba.

    Dim SonDoluSatir As Integer
    SonDoluSatir = Sheets("EXCEL").Cells(Rows.Count, "B").End(xlUp).Row
    Sheets("EXCEL").Range("B5:J" & SonDoluSatir).Copy
    Sheets("DEFTER").Cells(Rows.Count, "B").End(xlUp)(2, 1).PasteSpecial xlValues

 

[mkuru28]

Hocam aktarma sırasında yine boşluklar oluşuyor. B5:J35 aralığının tümünü kopyalayıp yapıştırıyor ve ikinci aktarmada arada bayağı boşluk oluşuyor.

 

[Korhan Ayhan]

Merhaba,

Hızlı çözüm için küçük bir örnek dosya paylaşabilirmisiniz. Örnek dosyanızı dosya paylaşım sitelerine yükledikten sonra indirme linkini forumda paylaşabilirsiniz.

 

[Muzaffer Ali]

Örnek dosya eklerseniz daha hızlı çözüm üretilebilir.,
Dosyanızı dosya.tc gibi bir paylaşım sitesine ekleyebilirsiniz.

 

[mkuru28]

Örnek dosya

Ekledim hocam. İlginize teşekkür ederim. Yanlız örnek dosya olduğu için ilk mesajdaki satır ve sütun aralıkları farklı oldu.

 

[Korhan Ayhan]

Paylaştığınız dosyada bahsettiğiniz sayfada formül yok!

Arkadaşlar bir çalışma kitabında EXCEL adında bir sayfam var. Bu sayfanın B5:J35 aralığında başka bir sayfadan formüller kullanarak aldığım değerler var.

 

[mkuru28]

Paylaştığınız dosyada bahsettiğiniz sayfada formül yok!

Hocam bu dosyayı örnek olarak hazırladığım için EXCEL sayfasından değil de DATA sayfasından kopyalanıp DEFTER sayfasına aktarılacak şekilde düzenledim. Satır ve sütun değerleri de farklı oldu. Bunun üzerinde örnek olarak nasıl olacağını gösterirseniz ben kodları kendi çalışma kitabıma uyarlayabilirim. Çünkü bu şekilde yapmam gereken birçok sayfa var.

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub Aktar()
    With Worksheets("DATA")
        .Range("$B$6:$J$20").AutoFilter Field:=2, Criteria1:="<>0", Operator:=xlAnd
        .Range("B7:J" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy
    End With
    Sheets("DEFTER").Cells(Rows.Count, "C").End(xlUp)(2, 1).PasteSpecial xlValues
    Worksheets("DATA").ShowAllData
End Sub

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Deftere_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Rng As Range, Copy_Rng As Range
    
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("DEFTER")
    
    On Error Resume Next
    Set Rng = Nothing
    Set Rng = S1.Range("C7:C" & S1.Rows.Count).SpecialCells(xlCellTypeFormulas, 2)
    On Error GoTo 0
    If Not Rng Is Nothing Then
        Set Copy_Rng = Rng.Offset(, -1).Resize(, 9)
        S2.Cells(S2.Rows.Count, 3).End(3)(2, 1).Resize(Copy_Rng.Rows.Count, 9).Value = Copy_Rng.Value
        S2.Range("B5") = 1
        S2.Range("B5").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=S2.Cells(S2.Rows.Count, 3).End(3).Row - 4, Trend:=False
        S2.Columns.AutoFit
        MsgBox "Aktarım tamamlanmıştır.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı!", vbCritical
    End If

    Set Rng = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[mkuru28]

Çok çok teşekkür ederim. Her iki kodu da denedim tam istediğim gibi olmuş. Emeğinize sağlık