Rapor liste oluşturma2

[ayyıldız55]

korhan bey çok yardımcı oldunuz tşk ama bu ekteki doya içindeki 1-2-3-4 günlerdeki kırmızı dolgulu alanlardan liste oluşturmak ve belirtilen tarihlerde süzebilmek istedim yapamadım.Yardımcı olursanız

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub ÖZET_RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Byte, Y As Byte, Satir As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("RAPOR")
    Satir = 4
    
    S1.Range("A4:M65536").Clear
    
    If S1.Range("B1") = "" Or S1.Range("B2") = "" Then
        MsgBox "Girdiğiniz tarihleri kontrol ediniz!", vbCritical, "Eksik Bilgi Girşi"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    For X = 1 To 31
        Set S2 = Nothing
        On Error Resume Next
        Set S2 = Sheets(CStr(X))
        On Error GoTo 0
        If Not S2 Is Nothing Then
            For Y = 45 To 54
                If S2.Cells(Y, 1) >= S1.Range("B1") And S2.Cells(Y, 1) <= S1.Range("B2") Then
                    S1.Cells(Satir, 1) = Satir - 3
                    S1.Cells(Satir, 2) = S2.Cells(Y, 1)
                    S1.Cells(Satir, 3) = S2.Cells(Y, 2)
                    S1.Cells(Satir, 5) = S2.Cells(Y, 4)
                    S1.Cells(Satir, 7) = S2.Cells(Y, 6)
                    S1.Cells(Satir, 9) = S2.Cells(Y, 8)
                    S1.Range("C" & Satir & ":D" & Satir).Merge
                    S1.Range("E" & Satir & ":F" & Satir).Merge
                    S1.Range("G" & Satir & ":H" & Satir).Merge
                    S1.Range("I" & Satir & ":M" & Satir).Merge
                    Satir = Satir + 1
                End If
            Next
        End If
    Next
    
    S1.Cells.Font.Name = "Calibri"
    S1.Cells.VerticalAlignment = xlCenter
    If Satir > 4 Then
        S1.Range("B4:B" & Satir - 1).NumberFormat = "m/d/yyyy"
        S1.Range("A4:F" & Satir - 1).HorizontalAlignment = xlCenter
        S1.Range("I4:M" & Satir - 1).HorizontalAlignment = xlCenter
        S1.Range("G4:G" & Satir - 1).NumberFormat = "#,##0.00 $"
        S1.Range("A4:M" & Satir - 1).Borders.LineStyle = 1
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ayyıldız55]

çok güzel olmuş elinize emeginize sağlık teşekkürler