O güne ait işlerin listelenmesi

[kelkitli]

Selamlar,
Ekteki dosyada:
Döneme göre süzme işlemi var.
Ancak tarihe göre o gün çalışan firmaları B7:B15 arası listelemek istiyorum
Nasıl bir değişiklik yapmalıyım. Yani D2 de yazılı tarihe göre o tarihte çalışılan E sütunundaki işler süzülüp teke indirilerek B7:B15 aralığına listelenecek. Genel toplamları C de günlük toplamları D de olacak. Yapabilen arkadaşların ilgilenmesi mümkünmü?

 

[hamitcan]

Verileriniz düzgün gibi görünüyor bence özet tablo ile bu işi çözelbilirsiniz.

 

[kelkitli]

Hamit Bey, sayfada başka veriler de kullanmaktayım. Akaryakıt, onarım ve diğer masrafların hepsi bir sayfada.

 

[Orion1]

Dosyanız ektedir.

Sub sefer59()
Dim sh As Worksheet, sat As Long, hcr As Range
Dim sat2 As Long
Sheets("FİRMA").Select
Set sh = Sheets("ÇALIŞMA")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If sh.AutoFilterMode = True Then sh.AutoFilterMode = False
sh.Range("A1").AutoFilter
Range("B7:C" & Rows.Count).ClearContents
sat = sh.Cells(Rows.Count, "B").End(xlUp).Row
sat2 = 7
For Each hcr In sh.Range("E2:E" & sat)
    If WorksheetFunction.CountIf(sh.Range("E2:E" & hcr.Row), _
    sh.Cells(hcr.Row, "E").Value) = 1 Then
        Cells(sat2, "B").Value = sh.Cells(hcr.Row, "E").Value
        Cells(sat2, "C").Value = WorksheetFunction.SumIf(sh.Range("E2:E" & sat), _
        sh.Cells(hcr.Row, "E").Value, sh.Range("F2:F" & sat))
        sat2 = sat2 + 1
    End If
Next hcr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly _
+ vbInformation, Application.UserName
End Sub

 

[kelkitli]

Hocam Teşekkür ederim. Hocam yazılı tarihte çalışan firmalar (10 dan fazlası kalacak) B7:B16 aralığına, B7:B16 aralığındaki firmaların genel toplamı C7:C16 aralığına, B7:B16 aralığındaki firmaların yazılı tarihdeki toplamı da D715 aralığına olursa çok memnun olurum. Saygılar.

 

[Orion1]

Hocam Teşekkür ederim. Hocam yazılı tarihte çalışan firmalar (10 dan fazlası kalacak) B7:B16 aralığına, B7:B16 aralığındaki firmaların genel toplamı C7:C16 aralığına, B7:B16 aralığındaki firmaların yazılı tarihdeki toplamı da D715 aralığına olursa çok memnun olurum. Saygılar.

genel toplam ,tarihtekilerin toplamı hangi sütunlarda oluyor?

 

[kelkitli]

Hocam, önce yaz D2 tarihinde çalışan firmalar B sütunundaki B7:B15 aralığına listelenecek.
Sonra B7:B15 de yazılı firmaların genel toplamları C7:C15 aralığına karşılarına, D2 tarihindeki seferleri de D715 aralığına yazılacak.

 

[asi_kral]

Hocam, önce yaz D2 tarihinde çalışan firmalar B sütunundaki B7:B15 aralığına listelenecek.
Sonra B7:B15 de yazılı firmaların genel toplamları C7:C15 aralığına karşılarına, D2 tarihindeki seferleri de D715 aralığına yazılacak.

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub tarihe_göre_veri_1967()
'Konu       :   Yazılan Tarihe Göre Firmaları ve Sonuçları Getir
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet, _
a As New Collection, b As Range, c As Long, _
d As Long, e As Long
On Error Resume Next
Application.ScreenUpdating = False
Set asi = Sheets("FİRMA"): Set kral = Sheets("ÇALIŞMA")
asi.Range("B7:D" & Rows.Count).ClearContents
c = kral.Range("A" & Rows.Count).End(xlUp).Row
d = 7
kral.Range("A1:L" & c).AutoFilter field:=2, Criteria1:=">=" & CLng( _
asi.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(asi.Range("D2"))
For e = 2 To c
If kral.Range("A" & e).EntireRow.Hidden <> True Then
a.Add kral.Cells(e, "E"), CStr(kral.Cells(e, "E"))
End If: Next
c = kral.Range("A" & Rows.Cont).End(xlUp).Row
For Each b In a
kral.Range("A1:L" & c).AutoFilter field:=2, Criteria1:=">=" & CLng( _
asi.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(asi.Range("D2"))
kral.Range("A1:L" & c).AutoFilter field:=5, Criteria1:=b
asi.Cells(d, "B") = b
asi.Cells(d, "D") = WorksheetFunction.Subtotal(9, kral.Range("F2:F" & c))
kral.Range("A1:L" & c).AutoFilter
asi.Cells(d, "C") = WorksheetFunction.SumIf(kral.Range("E:E"), b, kral.Range("F:F"))
d = d + 1: Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967 " & Application.UserName
End Sub

Dosyanız Ekte.

 

[asi_kral]

Üstteki dosya ve kod güncellenmiştir.

 

[kelkitli]

Teşekkür ederim Sayın asi_kral_1967.

 

[asi_kral]

Teşekkür ederim Sayın asi_kral_1967.

Kolay Gelsin.