Fatura çalışma

[hassas]

Sayın üstadlar öncelikli olarak hepinizin Ramazan bayramı mübarak olsun.
Ekli dosyaını içinde gerekli açıklamayı yaptığım bir çalışma dosyam var yardımcı olabilirseniz sevinirim.
Tüm hayatınızda kolaylıklar ve Başarılar dilerim.

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Kodlar önce tarih kontrolü yapar, eğer başlama tarihi bitiş tarihinden küçükse uyarı verir ve işlem yapmaz. Tarihler uygunsa eski verilerin silinip silinmeyeceğini sorar. Daha sonra girilen tarihler arasını listeler:

Sub rapor()
Set s1 = Sheets("DATA")
Set s2 = Sheets("SORGU")

baş = s2.[A2]
bit = s2.[B2]

If baş > bit Then
    MsgBox "Başlama tarihi bitiş tarihinden büyük olamaz", vbCritical
    Exit Sub
End If

son = s1.Cells(Rows.Count, "A").End(3).Row

uyarı = MsgBox("Eski veriler silinsin mi?", vbYesNo)

If uyarı = vbYes Then
    eski = WorksheetFunction.Max(4, s2.Cells(Rows.Count, "A").End(3).Row)
    s2.Range("A4:F" & eski).Clear
End If


For i = 3 To son
If s1.Cells(i, "A") >= baş And s1.Cells(i, "A") <= bit Then
    yeni = WorksheetFunction.Max(4, s2.Cells(Rows.Count, "A").End(3).Row + 1)
    s1.Range("A" & i & ":F" & i).Copy s2.Cells(yeni, "A")
End If
Next
End Sub

 

[hassas]

Sayın yusuf bey öncelikle çok teşekkür ederim.
burada sorgu sayfasında bulunan son hücrenin altınada otomatik dip toplamlarını getirebilirmi

 

[tahsinanarat]

Alt toplam için şu şekilde deneyebilirsiniz, Yusuf Beyin kodlarına ilaveten

Sub rapor()
Set s1 = Sheets("DATA")
Set s2 = Sheets("SORGU")

baş = s2.[A2]
bit = s2.[B2]

If baş > bit Then
    MsgBox "Başlama tarihi bitiş tarihinden büyük olamaz", vbCritical
    Exit Sub
End If

son = s1.Cells(Rows.Count, "A").End(3).Row

uyarı = MsgBox("Eski veriler silinsin mi?", vbYesNo)

If uyarı = vbYes Then
    eski = WorksheetFunction.Max(4, s2.Cells(Rows.Count, "A").End(3).Row)
    s2.Range("A4:F" & eski).Clear
End If


For i = 3 To son
If s1.Cells(i, "A") >= baş And s1.Cells(i, "A") <= bit Then
    yeni = WorksheetFunction.Max(4, s2.Cells(Rows.Count, "A").End(3).Row + 1)
    s1.Range("A" & i & ":F" & i).Copy s2.Cells(yeni, "A")
End If
Next
    Test

End Sub
Sub Test()
    Dim LR As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & LR + 1).Formula = "ALT TOPLAM"
    Range("B" & LR + 1).Formula = "=SUBTOTAL(9,B3:B" & LR & ")"
    Range("C" & LR + 1).Formula = "=SUBTOTAL(9,C3:C" & LR & ")"
    Range("D" & LR + 1).Formula = "=SUBTOTAL(9,D3:D" & LR & ")"
    Range("E" & LR + 1).Formula = "=SUBTOTAL(9,E3:E" & LR & ")"
    Range("f" & LR + 1).Formula = "=SUBTOTAL(9,f3:f" & LR & ")"
     son2 = [a65536].End(3).Row
    Range("a" & son2 & ":F" & son2).Font.Bold = True
    Range("B" & son2 & ":F" & son2).NumberFormat = "#,##0.00 "
    Range("a" & son2 & ":F" & son2).Font.Size = 14
    End Sub

 

[hassas]

Sayın tahsin ve yusuf beyler sizlere çok teşekkür, Tüm işlerinizde kolaylıklar dilerim.