Çözüldü Gün bazlı Açık kalma süresi hesaplama ve raporlama

[netzone]

Merhaba,

Dosya içerisinde dilimiz döndüğünce açıklama yapmaya çalıştık.
Özetlersek; Elimizde bulunan bir rapor listesinde J sütununda bulunan kontak açıldı - kontak kapalı ifadelerinin bulunduğu satırlar üzerinde işlem yaptırmak istiyoruz.
A sütununda bulunan tarihte bir çok kez açılıp kapanan kontak sürelerinin farklarını (Açık kalma sürelerini) B sütununda yer alan zaman dikkate alınarak toplanması ve bu bilgileri mevcut olan diğer sayfada raporlaması için yardımlarınıza ihtiyaç duyuyoruz.

Sorgulama yapılacak sayfa: Sayfa1
Rapor oluşacak sayfa: Özet

Yardımlarınız için şimdiden teşekkür ederim.

İyi çalışmalar.

 

[euphrates55]

yanlış oldu. sildim o yüzden

 

[netzone]

Merhaba,

@euphrates55 Başta yukarıda belirttiğim olmak üzere diğer yapılacakları yardımcı sütunlar kullanarak biraz uğraştırsa da çözüme ulaştırdım, ilginiz için teşekkürler.

İlerleyen zamanlarda tekrar böyle bir rapora ihtiyaç duyulabileceğinden yada bir başka arkadaşımızın ihtiyacı olabileceğinden çözüldü olarak işaretlemiyorum.

Söz konusu yardımcı olacak arkadaşlardan dosya üzerinde yapılması gereken bir istek de daha bulunmak isterim.
Gün içinde toplam açık kalma süresinin yan sütunlarına ilk açılış ve son kapanış zamanlarını da ekleyebilirsek tadından yenmez.

Teşekkür eder, iyi çalışmalar dilerim.

 

[Ömer BARAN]

Merhaba.
Soru Makro-VBA bölümüne açılmış. Aşağıdaki kod'u dener misiniz?

Sub ZAMAN_FARKLARI()
Dim s1, oz As Worksheet: Dim s1son, sat, satt, osat As Long: Dim ilk, son, fark As Date
Set s1 = Sheets("Sayfa1"): Set oz = Sheets("özet")
s1son = s1.Cells(Rows.Count, "A").End(3).Row

If oz.Cells(Rows.Count, "A").End(3).Row > 1 Then _
    oz.Range("A2:D" & oz.Cells(Rows.Count, "A").End(3).Row).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 2 To s1son
    If Right(s1.Cells(sat, "J"), 6) = "Açıldı" Then
        ilk = CDate(s1.Cells(sat, "A") + s1.Cells(sat, "B"))
        For satt = sat + 1 To s1son
            If Right(s1.Cells(satt, "J"), 6) = "Kapalı" Or _
                s1.Cells(sat, 1) <> s1.Cells(sat + 1, 1) Then
                If s1.Cells(satt, 1) <> s1.Cells(satt - 1, 1) Then
                    son = CDate(s1.Cells(satt - 1, 1) + 1)
                Else: son = CDate(s1.Cells(satt, 1) + s1.Cells(satt, 2))
                End If
            fark = CDate(son - ilk)
                If WorksheetFunction.CountIf(oz.[A:A], s1.Cells(sat, 1)) = 0 Then
                    osat = oz.Cells(Rows.Count, "A").End(3).Row + 1
                Else: osat = WorksheetFunction.Match(s1.Cells(sat, 1), oz.[A:A], 0)
                End If
                oz.Cells(osat, "A") = CDate(s1.Cells(sat, 1))
                oz.Cells(osat, "B").NumberFormat = "[hh]:mm:ss"
                oz.Cells(osat, "B") = oz.Cells(osat, "B") + fark
                oz.Range(oz.Cells(osat, "C"), oz.Cells(osat, "D")).NumberFormat = "dd/mm/yyyy hh:mm:ss"
                If oz.Cells(osat, "C") = "" Then oz.Cells(osat, "C") = ilk
                oz.Cells(osat, "D") = son
                fark = 0: sat = satt: Exit For
            End If
        Next
    End If
Next

Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem Tamamlandı", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[netzone]

Merhaba Ömer Bey,

Yazdığınız kod sorunsuz olarak çalıştı Teşekkür Ederim. Sayenizde uzun bir süre sonunda elde etmiş olduğum sonuçların doğruluğunu kontrol etme fırsatım oldu.

Bir üst mesajda belirtiğim gibi ufak bir dokunuş daha yapılabilirse (Pivot kullanarak elde edilebilir ama 2. bir işleme ihtiyaç duymamak için koda eklenebilirse) daha da faydalı olabileceği düşüncesindeyim.

Tekrar tekrar teşekkür eder, Saygılarımı sunarım.

İyi çalışmalar

 

[Ömer BARAN]

Kod cevabıma kırmızı renklendirdiğim kısımları ekledim/değiştirdim.
Sayfayı yenileyerek önceki cevabımı kontrol ediniz.