Saat aralığında günlere göre özellik saydırma

yavuz_yil · 15 Ekim 2017

Değerli Üstadlarım,

Aşağıda örnek linki mevcut dosyamdaki çalışmayı otomatik olarak saydırmak istiyorum.İş yerinde kullandığım ve özellikle yaz aylarında hazırlamakta çok vakit harcamak zorunda kaldığım bu tablo ile ilgili yardımcı olabilirseniz minnettar kalırım,

https://www.dosyaupload.com/dq1i

Saygılarımla,

muygun · 15 Ekim 2017

Merhaba;
Anladığım Sayfa1 sayfasındaki verilerin Belirlenen kriterlere göre YOLCU sayfasında sayılarını istiyorsunuz.
O halde;
Tarih verisi Sayfa1 sayfasında hangi sütunda?
SABAH AKŞAM GECE verisi Sayfa1 sayfasında hangi sütunda?
DAR GÖVDE GENİŞ GÖVDE verisi Sayfa1 sayfasında hangi sütunda?
Bunları belirlerseniz çözüm kolaylaşır.
İyi çalışmalar.

yavuz_yil · 15 Ekim 2017

muygun' Alıntı:
Merhaba;
Anladığım Sayfa1 sayfasındaki verilerin Belirlenen kriterlere göre YOLCU sayfasında sayılarını istiyorsunuz.
O halde;
Tarih verisi Sayfa1 sayfasında hangi sütunda?
SABAH AKŞAM GECE verisi Sayfa1 sayfasında hangi sütunda?
DAR GÖVDE GENİŞ GÖVDE verisi Sayfa1 sayfasında hangi sütunda?
Bunları belirlerseniz çözüm kolaylaşır.
İyi çalışmalar.

Sn.MUYGUN,

Öncelikle ilginiz için teşekkür ederim.Tarih verisini alacağımız sütun Sayfa1 de E sütünu, Sabah ,akşam ve gece verilerini kalkış saati sütunu olan M sütunundan tespit edeceğiz,dar/*geniş gövde verisi ise N sütununda...Umarım ifade edebilmişimdir...

Ziynettin · 15 Ekim 2017

Merhaba;

Dosyanız ekte,

Kod:

Sub ifade_say()
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("YOLCU")
a = s1.Range("B3:N" & s1.Cells(Rows.Count, 2).End(3).Row).Value
b = s2.Range("L8:L" & s2.Cells(Rows.Count, "L").End(3).Row).Value
c = s2.Range("N8:N" & s2.Cells(Rows.Count, "N").End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
saat1 = Format("08:00:00", "hh:mm:ss")
saat2 = Format("17:00:00", "hh:mm:ss")
saat3 = Format("23:59:59", "hh:mm:ss")
saat4 = Format("00:00:01", "hh:mm:ss")
On Error Resume Next

ReDim p(1 To UBound(a), 1 To 6)
For i = 1 To UBound(a)
    deg = Format(a(i, 4), "dd.mm.yyyy")
    If Not d.exists(deg) Then
        say = say + 1
        d(deg) = say
    End If
    tar = Format(a(i, 12), "hh:mm:ss")

'============= Sabah dar gövde =================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat1 And tar < saat2 Then
            p(d(deg), 1) = p(d(deg), 1) + 1
        End If
    Next x
'--------------Sabah geniş gövde ----------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat1 And tar < saat2 Then
            p(d(deg), 2) = p(d(deg), 2) + 1
        End If
    Next x

'========== Akşam dar gövde ====================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat2 And tar < saat3 Then
            p(d(deg), 3) = p(d(deg), 3) + 1
        End If
    Next x
'--------------Akşam geniş gövde ---------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat2 And tar < saat3 Then
            p(d(deg), 4) = p(d(deg), 4) + 1
        End If
    Next x

'=============Gece dar gövde ===================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat4 And tar < saat1 Then
            p(d(deg), 5) = p(d(deg), 5) + 1
        End If
    Next x
'--------------Gece geniş gövde ----------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat4 And tar < saat1 Then
            p(d(deg), 6) = p(d(deg), 6) + 1
        End If
    Next x
Next i

c = s2.Range("B7:B" & s2.Cells(Rows.Count, "B").End(3).Row).Value
ReDim k(1 To UBound(c), 1 To 6)
For i = 1 To UBound(c)
    deg = Format(c(i, 1), "dd.mm.yyyy")
    For y = 1 To 6
        k(i, y) = p(d(deg), y)
    Next y
Next i
s2.[C7].Resize(UBound(c), 6) = k
MsgBox "İşlem tamam...", vbInformation
End Sub

yavuz_yil · 16 Ekim 2017

Ziynettin' Alıntı:

Merhaba;

Dosyanız ekte,

Kod:

Sub ifade_say()
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("YOLCU")
a = s1.Range("B3:N" & s1.Cells(Rows.Count, 2).End(3).Row).Value
b = s2.Range("L8:L" & s2.Cells(Rows.Count, "L").End(3).Row).Value
c = s2.Range("N8:N" & s2.Cells(Rows.Count, "N").End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
saat1 = Format("08:00:00", "hh:mm:ss")
saat2 = Format("17:00:00", "hh:mm:ss")
saat3 = Format("23:59:59", "hh:mm:ss")
saat4 = Format("00:00:01", "hh:mm:ss")
On Error Resume Next

ReDim p(1 To UBound(a), 1 To 6)
For i = 1 To UBound(a)
    deg = Format(a(i, 4), "dd.mm.yyyy")
    If Not d.exists(deg) Then
        say = say + 1
        d(deg) = say
    End If
    tar = Format(a(i, 12), "hh:mm:ss")

'============= Sabah dar gövde =================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat1 And tar < saat2 Then
            p(d(deg), 1) = p(d(deg), 1) + 1
        End If
    Next x
'--------------Sabah geniş gövde ----------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat1 And tar < saat2 Then
            p(d(deg), 2) = p(d(deg), 2) + 1
        End If
    Next x

'========== Akşam dar gövde ====================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat2 And tar < saat3 Then
            p(d(deg), 3) = p(d(deg), 3) + 1
        End If
    Next x
'--------------Akşam geniş gövde ---------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat2 And tar < saat3 Then
            p(d(deg), 4) = p(d(deg), 4) + 1
        End If
    Next x

'=============Gece dar gövde ===================
    For x = 1 To UBound(b)
        If (a(i, 13)) = b(x, 1) And tar >= saat4 And tar < saat1 Then
            p(d(deg), 5) = p(d(deg), 5) + 1
        End If
    Next x
'--------------Gece geniş gövde ----------------
    For x = 1 To UBound(c)
        If (a(i, 13)) = c(x, 1) And tar >= saat4 And tar < saat1 Then
            p(d(deg), 6) = p(d(deg), 6) + 1
        End If
    Next x
Next i

c = s2.Range("B7:B" & s2.Cells(Rows.Count, "B").End(3).Row).Value
ReDim k(1 To UBound(c), 1 To 6)
For i = 1 To UBound(c)
    deg = Format(c(i, 1), "dd.mm.yyyy")
    For y = 1 To 6
        k(i, y) = p(d(deg), y)
    Next y
Next i
s2.[C7].Resize(UBound(c), 6) = k
MsgBox "İşlem tamam...", vbInformation
End Sub

Yardımlarınız için çok teşekkür ederim. Gold üye olmadığım için sizin eklediğiniz dosyayı indiremedim lakin verdiğiniz kodu dosyama eklediğimde aldığım sayı 451 oldu.Halbuki listede 484 adet uçak tipi sayması gerekir.Bu eksiklik nereden kaynaklanıyor acaba?

yavuz_yil · 16 Ekim 2017

yavuz_yil' Alıntı:
Yardımlarınız için çok teşekkür ederim. Gold üye olmadığım için sizin eklediğiniz dosyayı indiremedim lakin verdiğiniz kodu dosyama eklediğimde aldığım sayı 451 oldu.Halbuki listede 484 adet uçak tipi sayması gerekir.Bu eksiklik nereden kaynaklanıyor acaba?

Tamamen benim dikkatsizliğimden kaynaklı bir hata yapmışım ondan dolayı size bir soru sorma gereği duydum. Fark edince herşey normale döndü.Emekleriniz ve yardımlarınız için tekrar tekrar teşekkür ederim.

muygun · 16 Ekim 2017

Merhaba;
Soru çözümlenmiş ama alternatif olsun.
İyi çalışmalar.

Link:
http://s8.dosya.tc/server5/qrse6q/jv_Dar-Genis_Govde_Sefer_Sayisi__Calisma_.zip.html

Saat aralığında günlere göre özellik saydırma

yavuz_yil

muygun

Özel Üye

yavuz_yil

Ziynettin

Destek Ekibi

Ekli dosyalar

yavuz_yil

yavuz_yil

muygun

Özel Üye

Ekli dosyalar