İki Tarih Arasında Kalan Verileri aktarıp raporlamak

[vurkan]

Arkadaşlar Merhaba. Ekli dosyada RAPORLAR sayfasına ANA SAYFA ve ÖDENENLER sayfalarından İki Tarih Arasında Kalan Verileri aktarıp raporlamak istiyorum. Ancak bu dosyadaki tarihler kodlarla yazdırıldığından olsa gerek yazı (metin) formatında. İlgilenecek arkadaşlara şimdiden teşekkür ediyorum

http://s3.dosya.tc/server16/f5wonh/NAKLIYE_PROGRAMI_v6.rar.html

 

[turist]

Dosya İndirme Linki

Dosyayı indirip inceleyiniz.

 

[vurkan]

Sayın Turist Ellerinize Sağlık çok güzel olmuş. Başka bir başlık açmadan ilave bir soru daha sorsam. Şöyle ki;

Görsellik açısından ANA SAYFA ya satır renklendiren aşağıdaki kodu ekleyince ÖDENENLER sayfasına aktarılırken satır renkli olarak aktarılıyor. Bu da görsel olarak hoş olmuyor.

Renklendirme yaptığım kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range
If Intersect(Target, [B3:L5000]) Is Nothing Then
[B3:L5000].FormatConditions.Delete
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, 12))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 8
End With
With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 6
End With
End Sub

Biz L Sütununa çift tıklayınca satırın rengi hariç aktarması için
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.Calculation = XlCalculation.xlCalculationManual
Dim s1 As Worksheet
Dim s3 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s3 = Sheets("ÖDENENLER")
son3 = s3.Cells(65536, "E").End(3).Row + 1
sat = Target.Row
süt = Target.Column
If süt = 12 And sat > 2 And sat <= 5000 Then
Cancel = True
'With Target
'.Font.Name = "Wingdings"
'Font.Size = 16
'.HorizontalAlignment = xlCenter
'End With
If Target.Value = Format(Now, "dd.mm.yyyy") Then
Target.Value = ""
Else
Target.Value = Format(Now, "dd.mm.yyyy")
t = Target.Row
Range("B" & t & ":" & "L" & t).Select
Range("B" & Target.Row & ":" & "L" & Target.Row).Copy
s3.Select
s3.Range("B" & son3).Select
ActiveSheet.Paste
s3.Range("B2").Select
s1.Select
Range("L" & t).EntireRow.Delete
Range("B3").Select
End If
End If
If t > 2 Then
Application.Calculation = XlCalculation.xlCalculationAutomatic
MsgBox "BU SATIR ÖDENENLER SAYFASINA AKTARILMIŞTIR", vbInformation, "BİLGİ"
End If

End Sub

koduna nasıl bir ilave yapabiliriz. Teşekkürler

 

[turist]

Çift Tıklama ile ilgili kodu aşağıdaki gibi değiştirerek uygulayınız.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
Application.Calculation = XlCalculation.xlCalculationManual
Dim s1 As Worksheet
Dim s3 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s3 = Sheets("ÖDENENLER")
son3 = s3.Cells(65536, "B").End(3).Row + 1
sat = Target.Row
süt = Target.Column
If süt = 12 And sat > 2 And sat <= 5000 Then
Cancel = True
If Target.Value = Format(Now, "dd.mm.yyyy") Then
Target.Value = ""
Else
Target.Value = Format(Now, "dd.mm.yyyy")
t = Target.Row
s1.Range("B" & t & ":L" & t).Copy
s3.Range("B" & son3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        s3.Range("B" & son3 - 1 & ":L" & son3 - 1).Copy
    s3.Range("B" & son3 & ":L" & son3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
s1.Select
s1.Range("L" & t).EntireRow.Delete
s1.Range("B3").Select
End If
End If
If t > 2 Then
Application.ScreenUpdating = True
Application.Calculation = XlCalculation.xlCalculationAutomatic
MsgBox "BU SATIR ÖDENENLER SAYFASINA AKTARILMIŞTIR", vbInformation, "BİLGİ"
End If

End Sub

Ayrıca RAPORLAR sayfasındaki Sayfa Kodu bölümündeki kod'a aşağıdaki gibi bir satırı ilave ediniz.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ValueToProcess As Variant
Application.ScreenUpdating = False
On Error Resume Next
For i = 3 To Sheets("ANA SAYFA").Cells(Rows.Count, 2).End(3).Row
ValueToProcess = DateValue(Sheets("ANA SAYFA").Cells(i, 2).Value)
Sheets("ANA SAYFA").Cells(i, 2).Value = ValueToProcess
Next
For i = 3 To Sheets("ÖDENENLER").Cells(Rows.Count, 2).End(3).Row
ValueToProcess = DateValue(Sheets("ÖDENENLER").Cells(i, 2).Value)
Sheets("ÖDENENLER").Cells(i, 2).Value = ValueToProcess
Next
Sheets("RAPORLAR").Range("A3:I5000") = Empty
Sheets("RAPORLAR").Range("K3:S5000") = Empty
Sheets("ANA SAYFA").Range("B2:K" & Sheets("ANA SAYFA").Cells(Rows.Count, 2).End(3).Row).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("RAPORLAR").Range("AZ1:BJ2"), CopyToRange:=Sheets("RAPORLAR").Range("A2:I3"), Unique:= _
False
Sheets("ÖDENENLER").Range("B2:K" & Sheets("ÖDENENLER").Cells(Rows.Count, 2).End(3).Row).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("RAPORLAR").Range("BO1:BY2"), CopyToRange:=Sheets("RAPORLAR").Range("K2:S3"), Unique:= _
False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[vurkan]

Sayın Turist Çok teşekkür ederim. Harika olmuş.

"Sen de çok şey istiyorsun artık" demesseniz bir ricam daha olsa şöyle ki; Benim için yazdığınız raporlama koduna bir ilave yapsak. Bu Sayfayı çıktı olarak alacağımdan Örneğin C1 ve M1 Hücrelerine Plaka, Araç sahibi, Veya Nakliye Yeri yazılınca (Başlıktaki diğer hücreler de kullanılabilir veya ilave edilebilir) onlara göre de raporlasa. Mesela 34BYC63 Plakalı araç Şu tarihler arasında hangi işleri yapmış. Veya Bu tarihler arasında Rivada kimler çalışmış gibi. Ana sayfada bunları Filtre ile yapabiliyoruz Ama buradan çıktı alırsam daha güzel olur. Size zahmet olmazsa ilgilenirseniz sevinirim. Saygılar.

 

[turist]

Dosyanızı İndirin
İnceleyin.
Not:Rapor sayfasında tarihleri boş bıralırsanız bütün işlemler listelenir.
Plaka, Araç Sahibi, Nakliye Yeri seçerek listeleme yapmak için çeşitli denemeler yapınız.

 

[vurkan]

Sayın Turist. Harika olmuş . Elleriniz dert görmesin.

Ancak raporlarda tarih aralıklarını alırken ÖDENENLER sayfasını da B sütununa göre süzüyor. Oysa ödemesi yapılan tarih ÖDENENLER sayfasının L sütununda.
Bir de hücre kenarlıkları dikkatimi çekti. Değişik raporlamalarda İçi boşaldığı halde silinmeyen hücre kenarlıkları kalıyor. Dinamik olmuyor. İlk 3 satır hariç kenarlıklar içi dolu satırlar kadar azalıp çoğalamaz mı.
Ben A3 hücresi doluysa A3:I3 arasını Koşullu biçimlendirmeyle kenarları çizili yapmaya çalıştım ama olmadı. Saygılar.