Belirlenen sütunun dolu satırlarını aktarmak

[EKREM1661]

Değerli Arkadaşlar..! Örneklerden yararlanmaya çalıştım, fakat hata aldım..
Açıklamasını yaptığım ekli dosyada, küçültülmüş bir örnekte,
C sütununda veri bulundurma şartına bağlı olarak, istenilen veri aralığını diğer sayfaya aktarma konusunda yardım gerekiyor..
(C-D-E sütunlarındaki karşılıklı verileri de birleştirerek aktarsın..)
Hayırlı çalışmalar dileğiyle..

 

[metin_0606]

Değerli Arkadaşlar..! Örneklerden yararlanmaya çalıştım, fakat hata aldım..
Açıklamasını yaptığım ekli dosyada, küçültülmüş bir örnekte,
C sütununda veri bulundurma şartına bağlı olarak, istenilen veri aralığını diğer sayfaya aktarma konusunda yardım gerekiyor..
(C-D-E sütunlarındaki karşılıklı verileri de birleştirerek aktarsın..)
Hayırlı çalışmalar dileğiyle..

Deneyiniz

Sub getir()
Dim syf1 As Worksheet
Dim syf2 As Worksheet
Dim son As Integer
Dim a As Integer

Set syf1 = Sheets("Sayfa1")
Set syf2 = Sheets("Sayfa2")
a = 9
son = syf1.Cells(Rows.Count, 1).End(3).Row

For i = 11 To son
    
    If syf1.Cells(i, 2) <> "" And syf1.Cells(i, 3) <> "" And syf1.Cells(i, 4) <> "" And syf1.Cells(i, 5) <> "" And syf1.Cells(i, 6) <> "" And syf1.Cells(i, 7) <> "" Then
        
        syf2.Cells(a, 2) = syf1.Cells(i, 2)
        syf2.Cells(a, 3) = syf1.Cells(i, 3)
        syf2.Cells(a, 4) = syf1.Cells(i, 6)
        syf2.Cells(a, 5) = syf1.Cells(i, 7)
        a = a + 1
        
       End If
Next i
End Sub

 

[metin_0606]

Deneyiniz

Sub getir()
Dim syf1 As Worksheet
Dim syf2 As Worksheet
Dim son As Integer
Dim a As Integer

Set syf1 = Sheets("Sayfa1")
Set syf2 = Sheets("Sayfa2")
a = 9
son = syf1.Cells(Rows.Count, 1).End(3).Row

For i = 11 To son
   
    If syf1.Cells(i, 2) <> "" And syf1.Cells(i, 3) <> "" And syf1.Cells(i, 4) <> "" And syf1.Cells(i, 5) <> "" And syf1.Cells(i, 6) <> "" And syf1.Cells(i, 7) <> "" Then
       
        syf2.Cells(a, 2) = syf1.Cells(i, 2)
        syf2.Cells(a, 3) = syf1.Cells(i, 3)
        syf2.Cells(a, 4) = syf1.Cells(i, 6)
        syf2.Cells(a, 5) = syf1.Cells(i, 7)
        a = a + 1
       
       End If
Next i
End Sub

c sutunun doluluk şekline göre getiriyor

Sub getir()
Dim syf1 As Worksheet
Dim syf2 As Worksheet
Dim son As Integer
Dim a As Integer

Set syf1 = Sheets("Sayfa1")
Set syf2 = Sheets("Sayfa2")
a = 9
son = syf1.Cells(Rows.Count, 1).End(3).Row

For i = 11 To son
    
    If syf1.Cells(i, 3) <> "" Then
        
        syf2.Cells(a, 2) = syf1.Cells(i, 2)
        syf2.Cells(a, 3) = syf1.Cells(i, 3)
        syf2.Cells(a, 4) = syf1.Cells(i, 6)
        syf2.Cells(a, 5) = syf1.Cells(i, 7)
        a = a + 1
        
       End If
Next i
End Sub

 

[kulomer46]

Merhaba

Dosya Ek'tedir.

Selamlar...

 

[EKREM1661]

Sn. metin_0606 ve Sn. kulomer46 ziyadesiyle teşekkürler.. Ellerinize sağlık..
Sn. kulomer46 örneğinde C-D-E sütunlarındaki verileri birleştirdiği için, bu örnek bu yöndeki talebi de gidermiş oldu..
Sn. kulomer46 son olarak, makrodaki "timer" ne için olduğunu soracağım..
Bir de, eğer butonu sayfa 2'ye değil de Sayfa1'e konumlandırırsak kodlamaya nasıl bir şekil vermek gerekiyor..
Yani Sayfa1 de söz konusu verileri, Sayfa1'den butonla Sayfa2'ye göndermek..

 

[kulomer46]

Merhaba

Aşağıda eklenen kodlar çalışmanızdaki tüm sayfalarda çalışacak şekilde düzenlenmiştir.
Yani bu kod bloğunu Sayfa1 'den de çalıştırabilirsiniz Sayfa2 'dende. Aynı işi yapar.

Makrodaki Timer kodları, butona tıklayıp her yeni aktarma yaptığınızda tablonun silinip yeniden yüklendiğini size hissettirmek için eklenmiştir.
Yani butona her tıkladığınızda tablo sıfırdan güncellenmektedir hissini size hissettirmek için bir görsel güzellik olarak kodlarda bulunmaktadır.

Selamlar...

Sub Aktar()
'16.06.2020   14:19

Sheets("Sayfa2").Select
Sheets("Sayfa2").Range("B9:E65500").ClearContents
timer1 = Timer
Do While Timer - timer1 < 0.7
Loop
sonc = Sheets("Sayfa1").Cells(Rows.Count, 3).End(3).Row

sat = 9
For i = 11 To sonc
  
    If Len(Trim(Sheets("Sayfa1").Cells(i, 3))) > 0 Then
      
        Sheets("Sayfa2").Cells(sat, 2) = Sheets("Sayfa1").Cells(i, 2)
        Sheets("Sayfa2").Cells(sat, 3) = Sheets("Sayfa1").Cells(i, 3) & "  -  " & Sheets("Sayfa1").Cells(i, 4) _
        & "  -  " & Sheets("Sayfa1").Cells(i, 5)
        Sheets("Sayfa2").Cells(sat, 4) = Sheets("Sayfa1").Cells(i, 6)
        Sheets("Sayfa2").Cells(sat, 5) = Sheets("Sayfa1").Cells(i, 7)
      
        sat = sat + 1
  
    End If

Next

End Sub

 

[EKREM1661]

Üstad.. Çok-çok teşekkürler, harika olmuş.. Elinize sağlık..Aynı zamanda aktarmanın da ayrıntısını öğrenmiş olduk..

 

[kulomer46]

Bilgi paylaşıldıkça güzeldir.

Selamlar...

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Verileri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
    Dim Baglanti As Object, Kayit_Seti As Object, Dosya As String
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Dosya = ThisWorkbook.FullName
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
    Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Dosya & _
    ";Extended Properties=""Excel 12.0;Hdr=No"""

    Kayit_Seti.Open "Select F1, F2&F3&F4, F5, F6 From [" & S1.Name & "$B11:G] Where F2 Is Not Null", Baglanti, 1, 1
    If Kayit_Seti.RecordCount > 0 Then
        S2.Range("B9").CopyFromRecordset Kayit_Seti
        S2.Cells.Columns.AutoFit
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[EKREM1661]

Korhan üstad.. Size de çok çok teşekkürler.. Elinize sağlık.. Farklı bir alternatif elimde olmuş oldu..