aylık toplam alma ve aylık sıralama

[emrexcel123]

arkadaşlar ve üstadlar selamlar
sorunum bir çek dökümünden aldığım vadelerin diğer bir sütunda "aaaa yyyy" şeklindeki formatından yola çıkarak başka bir sayfaya gelişmiş filtre yardımı ile yerleştirip çek dökümünde yer alan "aaaa yyyy" şeklindeki vadelerin toplamını alıyorum fakat sıralama yaparken manuel yapıldığında sıralama da sorun olmuyor ancak makro ile yapınca vadeler metin olarak algılandığından metin şeklinde sıralanıyor şöyle ki >>
asıl sıralama şöyle olmasına karşın
Temmuz 2007
Ağustos 2007
Eylül 2007
Ekim 2007...
fakat makro ile yaptığımda
Ağustos 2007
Aralık 2007
Ekim 2007
Eylül 2007....
gibi sıralama yapıyor ayrıca toplam alırken aynı zamanda durum şartını da göz önüne alması gerekiyor bunun için ne yapılabilir yardımcı olacak arkadaşlara teşekkür ederim dosya ektedir
NOT : İÇERİKTE MAKRO YOKTUR DOSYA ÇOK YÜKLÜ OLDUĞU İÇİN TANIMLAMA YAPAMADIM ÖZÜR DİLİYORUM...

 

[Ferhat Pazarçevirdi]

Dosyadan ve anlattıklarınızdan anladığım kadarıyla, ÖZet Tablo sizin işinizi rahatlıkla görebilir.(Tabi illa kod diye ısrar etmezseniz)

Ekteki dosyayı inceleyiniz.

 

[emrexcel123]

sn fpc üstadım bende özet tabloyu denedim fakat asıl dosya 10.000 küsür satır olduğu için ve yanlarına yazılan "aaaa yyyy" formatıda makro ile yaptığım ve sadece istenilen durumu görmek istediğim için makro ile yapılması cazip geldi bana yine de yardımlarınız için tşk ederim...
NOT: asıl dosyaya özet tablo koyduğum zaman dosya boyutu 1 MB 'tan 5 MB'a fırlıyor

 

[Ferhat Pazarçevirdi]

Sn.emrexcel123

Aşağıdaki kodu bir modul sayfasına kopyalayarak çalıştırınız.

Sub raporla()
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
sh2.Columns("A:C").Delete
sh2.Cells(1, 1) = "Durumu"
sh2.Cells(1, 1).Interior.ColorIndex = 43
With sh2.Cells(2, 1).Validation
  .Delete
  .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
   Formula1:="Ciro edildi,Karşılığı yok,Tahsil edildi"
End With
With sh2.Cells(2, 1)
   .Value = "Ciro edildi"
   .Interior.ColorIndex = 53
   .Font.FontStyle = "Kalın"
   .Font.ColorIndex = 2
End With
With sh2.Cells(3, 1)
  .Value = "Aylar Dağılımı"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
With sh2.Cells(3, 2)
  .Value = "mmmm/yyyy"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
With sh2.Cells(3, 3)
  .Value = "Aylık Toplam"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
son1 = sh1.Cells(65536, 1).End(xlUp).Row
For i = 2 To son1
    x = Application.WorksheetFunction.CountIf(sh1.Range("D2:D" & i), sh1.Cells(i, 4))
    If x = 1 Then
        son2 = sh2.Cells(65536, 1).End(xlUp).Row
        sh2.Cells(son2 + 1, 1) = sh1.Cells(i, 4)
        yil = Year(sh2.Cells(son2 + 1, 1))
        ay = Month(sh2.Cells(son2 + 1, 1))
        sh2.Cells(son2 + 1, 2) = (ay & "/" & yil)
        sh2.Cells(son2 + 1, 2) = sh2.Cells(son2 + 1, 2) * 1
        sh2.Cells(son2 + 1, 2).NumberFormat = "mmmm yyyy"
        sh2.Cells(son2 + 1, 3).Formula = "=SUMPRODUCT(((Sayfa1!d2:d" & son1 & ")=Sayfa2!a" & son2 + 1 & ")*((Sayfa1!E2:E" & son1 & ")=Sayfa2!A2)*Sayfa1!c2:c" & son1 & ")"
        sh2.Cells(son2 + 1, 3).NumberFormat = "#,##0.00"
    End If
Next i
sh2.Select
sh2.Range("A3:B" & son2 + 1).Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4"), Order2:=xlAscending, Header:=xlGuess
sh2.Range("B4:B" & son2 + 1).Interior.ColorIndex = 43
sh2.Cells(2, 1).Select
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

 

[emrexcel123]

üstadım çok güzel fakat en sondaki topla.çarpım formülünü makro ile yapmamız mümkün müdür?...
(formül çok iyi belirtmek isterim)

 

[Ferhat Pazarçevirdi]

Haklısın, dosya boyutu çok önemli her zaman... O halde, aşağıdaki kodlar işini görecektir.

 Sub rapor1()
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
On Error Resume Next
sh2.Shapes("fpc001").Delete
sh2.Shapes("fpc002").Delete
sh2.Columns("A:G").Delete
son1 = sh1.Cells(65536, 1).End(xlUp).Row
sh2.Cells(1, 7) = "Liste"
sh2.Cells(1, 7).Font.ColorIndex = 2
For j = 2 To son1
    x = Application.WorksheetFunction.CountIf(sh1.Range("E2:E" & j), sh1.Cells(j, 5))
    If x = 1 Then
        sonlst = sh2.Cells(65536, 7).End(xlUp).Row
        sh2.Cells(sonlst + 1, 7) = sh1.Cells(j, 5)
        sh2.Cells(sonlst + 1, 7).Font.ColorIndex = 2
    End If
Next j
Set lstbx = sh2.DropDowns.Add(0, 12.75, 212, 15.75)
With lstbx
  .Name = "fpc001"
  .ListFillRange = "$G$2:$G$" & sonlst + 1
  .LinkedCell = "Sayfa2!$A$2"
  .DropDownLines = 3
  .Display3DShading = True
  .OnAction = "rapor2"
End With
Set cmnd = sh2.Buttons.Add(160, 12.75, 63.75, 17.25)
With cmnd
  .Name = "fpc002"
  .Caption = "Ana Menu"
  .OnAction = "rapor3"
End With
sh2.Rows("2:2").RowHeight = 17.5
sh2.Cells(2, 1) = 1
sh2.Cells(2, 2) = sh2.Cells(1, 7).Offset(1, 0)
sh2.Cells(1, 1) = "Durumu"
sh2.Range("A1:C1").Interior.ColorIndex = 43
With sh2.Cells(3, 1)
  .Value = "Aylar Dağılımı"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
With sh2.Cells(3, 2)
  .Value = "mmmm/yyyy"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
With sh2.Cells(3, 3)
  .Value = "Aylık Toplam"
  .Interior.ColorIndex = 44
  .Font.FontStyle = "Kalın"
End With
sh2.Columns("A:A").ColumnWidth = 14
sh2.Columns("B:B").ColumnWidth = 12
sh2.Columns("C:C").ColumnWidth = 12
Set sh1 = Nothing
Set sh2 = Nothing
Set lstbx = Nothing
Set cmnd = Nothing
Call rapor2
End Sub
Sub rapor2()
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
son1 = sh1.Cells(65536, 1).End(xlUp).Row
son2 = sh2.Cells(65536, 1).End(xlUp).Row
sh2.Range("A4:A" & son2 + 1).ClearContents
son2 = 0
sh2.Cells(2, 2) = sh2.Cells(1, 7).Offset(sh2.Cells(2, 1), 0)
For i = 2 To son1
    x = Application.WorksheetFunction.CountIf(sh1.Range("D2:D" & i), sh1.Cells(i, 4))
    If x = 1 Then
        son2 = sh2.Cells(65536, 1).End(xlUp).Row
        sh2.Cells(son2 + 1, 1) = sh1.Cells(i, 4)
        yil = Year(sh2.Cells(son2 + 1, 1))
        ay = Month(sh2.Cells(son2 + 1, 1))
        sh2.Cells(son2 + 1, 2) = (ay & "/" & yil)
        sh2.Cells(son2 + 1, 2) = sh2.Cells(son2 + 1, 2) * 1
        sh2.Cells(son2 + 1, 2).NumberFormat = "mmmm yyyy"
'       sh2.Cells(son2 + 1, 3).Formula = "=SUMPRODUCT(((Sayfa1!d2:d" & son1 & ")=Sayfa2!a" & son2 + 1 & ")*((Sayfa1!E2:E" & son1 & ")=Sayfa2!B2)*Sayfa1!c2:c" & son1 & ")"
        sh2.Cells(son2 + 1, 3) = Evaluate("=SUMPRODUCT(((Sayfa1!d2:d" & son1 & ")=Sayfa2!a" & son2 + 1 & ")*((Sayfa1!E2:E" & son1 & ")=Sayfa2!B2)*Sayfa1!c2:c" & son1 & ")")
        sh2.Cells(son2 + 1, 3).NumberFormat = "#,##0.00"
    End If
Next i
sh2.Select
sh2.Range("A3:C" & son2 + 1).Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4"), Order2:=xlAscending, Header:=xlGuess
sh2.Range("B4:B" & son2 + 1).Interior.ColorIndex = 43
sh2.Cells(2, 1).Select
Set sh1 = Nothing
Set sh2 = Nothing
Set lstbx = Nothing
End Sub
Sub rapor3()
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
On Error Resume Next
sh2.Shapes("fpc001").Delete
sh2.Shapes("fpc002").Delete
sh2.Columns("A:G").Delete
Sheets("Sayfa1").Select
End Sub

 

[emrexcel123]

tek kelimeyle PERFECT ! üstadım başarılarının devamını dilerim...