Soru Veri Birleştirme

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
İ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.


221979
 

Ekli dosyalar

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
Çok teşekkür ederim.
Sağolun.
 

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
Düzenleme iptal edildi.
 
Son düzenleme:

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
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.

222207222208
 

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
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.
 

Ekli dosyalar

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
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.
 

Ekli dosyalar

konas06

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,332
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
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

Altın Üye
Katılım
27 Kasım 2007
Mesajlar
654
Excel Vers. ve Dili
ofis 2016 Türkçe
Hocam ilginiz için çok teşekkür ederim.
 
Üst