İki tarih arası rapor alma

[Usyk]

Merhaba

Userform üzerine girdiğim 2 TextBox ile Rapor! Sayfasına tarih aralığındaki kayıtları çekiyorum.

Ama kayıtlara ait kodlara göre ilgili bölüm ve alt bölüm altına yazdıramadım.

Üstadların ilgi ve yardımına sunulur.

http://s3.dosya.tc/server14/0rcxpc/Rapor_Ornek.rar.html

 

[Usyk]

Dardayım arkadaşlar yardım ederseniz sevinirim.

 

[alicimri]

textbox lara tarihi "gg.aa.yyyy" formatında girin

Private Sub CommandButton1_Click()
on error resume  next
Application.ScreenUpdating = False
Sheets("Rapor").Cells.ClearContents
    Sheets.Add
    ActiveSheet.Name = "x"
say = Sheets("Veri").Cells(Rows.Count, "A").End(3).Row
ilk = CDbl(DateValue(TextBox1))
son = CDbl(DateValue(TextBox2))
    Sheets("Veri").Range("$A$1:$E$" & say).AutoFilter Field:=2, Criteria1:= _
        ">=" & ilk, Operator:=xlAnd, Criteria2:="<=" & son
    Sheets("Veri").Range("B2:E" & say).Copy Sheets("x").Range("a2")
say1 = Sheets("x").Cells(Rows.Count, "A").End(3).Row
    ActiveWorkbook.Worksheets("x").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("x").Sort.SortFields.Add Key:=Worksheets("x").Range("B2:B" & say1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("x").Sort.SortFields.Add Key:=Worksheets("x").Range("A2:A" & say1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("x").Sort
        .SetRange Worksheets("x").Range("A2:D" & say1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    say2 = 1
    For i = 2 To say1
    If Left(Sheets("x").Range("B" & i), 1) <> Left(Sheets("x").Range("B" & i - 1), 1) Then
    Sheets("Rapor").Range("C" & say2).Value = "BÖLÜM " & Left(Sheets("x").Range("B" & i), 1)
     say2 = say2 + 1
    End If
      If Sheets("x").Range("C" & i) <> Sheets("x").Range("C" & i - 1) Then
    Sheets("Rapor").Range("C" & say2).Value = Sheets("x").Range("C" & i)
    say2 = say2 + 1
    End If
      If Left(Sheets("Rapor").Range("C" & i - 1), 3) <> "BÖL" Or Left(Sheets("Rapor").Range("C" & i - 1), 3) <> "ALT" Then
    Sheets("Rapor").Range("C" & say2).Value = Sheets("x").Range("D" & i)
    say2 = say2 + 1
    End If
   Next
   Application.DisplayAlerts = False
Sheets("x").Delete
Application.DisplayAlerts = True
Sheets("Rapor").Activate
Application.ScreenUpdating = True
End Sub

 

[Usyk]

Sayın alicimri

İlginiz ve yardımınız için teşekkür ederim. Örnek dosya üzerinde denedim sorun yok.

Orjinal dosyamda bölüm ve alt bölüm adları örnekteki gibi aynı isim ve seri değil. Uyarlamaya çalışacağım. Olacak mı bilmiyorum. Sonucu paylaşırım.

Tekrar çok teşekkür ediyorum.