Tarihe Göre Günlük Puantaj Raporu

[iplikci_80]

GÜN sayfası G1 hücresine girilen tarihe ait HB sayfasındaki verileri, tarih girdiğimde GÜN sayfası B sütununa HB sayfası C sütunundaki isimler, GÜN sayfası F sütununa HB sayfasındaki puantajda rapor tarihinde 1 var ise 12 Saat, 0,5 var ise 6 Saat boş ise boş olacak şekilde raporlama hususunda yardımlarınızı rica ediyorum.
Örneğin birinci sıradaki Ali için ayın 14 Y sütunu 1 olduğu için GÜN sayfası F3 12 saat, 0,5 olsa idi 6 saat gibi.

 

[YUSUF44]

Aşağıdaki kodları GÜN sayfasının kod bölümüne yapıştırıp deneyin, G1 hücresini değiştirdiğinizde çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [G1]) Is Nothing Then Exit Sub
sonA = WorksheetFunction.Max(4, Cells(Rows.Count, "A").End(3).Row)
Range("B3:F" & sonA).ClearContents

If Target = "" Then Exit Sub
If IsDate(Target) = False Then Exit Sub
Set s1 = Sheets("HB")
son = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "C").End(3).Row)

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
If WorksheetFunction.CountIf(s1.[3:3], Target) > 0 Then
    sut = WorksheetFunction.Match(Target, s1.[3:3], 0)
Else
    MsgBox "HB sayfasında " & Format(Target, "dd/mm/yyyy") & " gününe ait kayıt bulunmamaktadır!", vbInformation
    Exit Sub
End If
[H1] = sut
sorgu = "select F1, F3, '', '', F" & sut - 2 & " as sure from [HB$C6:BQ" & son & "] where F1 is not null"
Set rs = con.Execute(sorgu)

[B3].CopyFromRecordset rs
sonF = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "C").End(3).Row)

For Each hucre In Range("F3:F" & sonF)
    hucre = hucre * 12 & " saat"
Next
End Sub

 

[iplikci_80]

Çok teşekkür ederim.