Soru Veri Birleştirme

[konas06]

İyi akşamlar,
Bu bilgileri, sürelere bakıp 00:00 dan büyük olanları 2.sayfada makro ile birleştirmek istiyorum.
Değerli vaktini yardım için ayıran üstatlara şimdiden teşekkür ederim.

 

[veyselemre]

Sub test()
    Dim i As Long, ii As Long, sat As Long, s2 As Worksheet

    Set s2 = Sheets("Sayfa2")
    s2.Range("E6:I" & Rows.Count).Clear

    sat = 6
    With Sheets("Sayfa1")
        For i = 8 To 14 Step 3
            For ii = 5 To .Cells(Rows.Count, i).End(3).Row
                If .Cells(ii, i).Value > "00:00" Then
                    .Cells(ii, 3).Resize(, 3).Copy s2.Cells(sat, "e")
                    .Cells(ii, i).Resize(, 2).Copy s2.Cells(sat, "h")
                    sat = sat + 1
                End If
            Next ii
        Next i
    End With
End Sub

 

[konas06]

Çok teşekkür ederim.
Sağolun.

 

[konas06]

Düzenleme iptal edildi.

 

[konas06]

Sayın veyselemre,
Veriler eklendiğinde, kod kasmaya başladı,
Dolayısıyla; Verileri sadeleştirmek gerektiğinde,
Tarih aralığı ve süreyi dinamik yapıya dönüşmek için nasıl bir değişiklik yapmak gerekebilir.

 

[konas06]

Dosya eklememiştim.
Veriler çoğaldıkça kod yavaş çalıştığından,
Tarih ve süre kriteri ekleyerek daha hızlı çalışması sağlanabilir mi?
Değerli vaktini yardımcı olmak için ayıran üstatlara teşekkür ederim.

 

[veyselemre]

Sub test()
    Dim i As Long, ii As Long, sat As Long, s2 As Worksheet
    Dim sure1, sure2, tar1, tar2

    Set s2 = Sheets("Sayfa2")
    s2.Range("E6:I" & Rows.Count).Clear

    tar1 = s2.Range("E2")
    tar2 = s2.Range("F2")
    sure1 = s2.Range("H2")
    sure2 = s2.Range("I2")

    sat = 6
    With Sheets("Sayfa1")
        For ii = 5 To .Cells(Rows.Count, "C").End(3).Row
            If .Cells(ii, "C").Value >= tar1 And .Cells(ii, "C").Value <= tar2 Then
                For i = 8 To 14 Step 3
                    If .Cells(ii, i).Value >= sure1 And .Cells(ii, i).Value <= sure2 Then
                        .Cells(ii, 3).Resize(, 3).Copy s2.Cells(sat, "e")
                        .Cells(ii, i).Resize(, 2).Copy s2.Cells(sat, "h")
                        sat = sat + 1
                    End If
                Next i
            End If
        Next ii
    End With

End Sub

 

[konas06]

Çok teşekkür ederim.

 

[konas06]

Yeni bir çalışma için ekte bulunan, dosyadaki kodda değişikliğe ihtiyaç duyulmuştur.
Dosya da bulunan kod, forumda veyselemre hoca tarafından oluşturulmuştur.
Değerli vaktini yardım için ayıran üstatlara şimdiden teşekkür ederim.

 

[konas06]

Kodda bir değişiklik gerektiği için yeni konu açmak istememiştim.
Çözüm önerisi için yeni konuya mı taşımalıyım?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Birlestir()
    Dim S1 As Worksheet, S2 As Worksheet, Say As Long
    Dim Veri_A As Variant, Veri_B As Variant, Baslik As Variant
    Dim Son As Long, X As Long, Y As Integer, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Son = S1.Cells(S1.Rows.Count, "C").End(3).Row
    If Son < 6 Then Son = 6
    
    Veri_A = S1.Range("C5:E" & Son).Value
    Veri_B = S1.Range("H5:O" & Son).Value
    Baslik = S1.Range("H3:O3").Value
    
    ReDim Liste(1 To UBound(Veri_A, 1) * 4, 1 To 6)
    
    For Y = LBound(Veri_B, 2) To UBound(Veri_B, 2) Step 2
        For X = LBound(Veri_A, 1) To UBound(Veri_A, 1)
            If Veri_A(X, 1) <> "" Then
                Say = Say + 1
                Liste(Say, 1) = Veri_A(X, 1)
                Liste(Say, 2) = Veri_A(X, 2)
                Liste(Say, 3) = Veri_A(X, 3)
                Liste(Say, 4) = Baslik(1, Y)
                Liste(Say, 5) = Veri_B(X, Y)
                Liste(Say, 6) = Veri_B(X, Y + 1)
            End If
        Next
    Next
    
    S2.Range("E6:J" & S2.Rows.Count).ClearContents
    S2.Range("E6").Resize(Say, 6) = Liste
    S2.Columns.AutoFit
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[konas06]

Hocam ilginiz için çok teşekkür ederim.