Listeleme

[ycimen]

"Vurulup tertemiz alnından uzanmış yatıyor
Bir hilal uğruna Yarab ne güneşler batıyor
Ey bu topraklar için toprağa düşmüş asker
Gökten ecdad inerek öpse o pak alnı değer
Ne büyüksün ki kanın kurtarıyor tevhidi
Bedrin aslanları ancak bu kadar şanlı idi
Sana dar gelmeyecek makberi kimler kazsın
Gömelim seni tarihe desem sığmazsın
Ey şehit oğlu şehit isteme benden makber
Sana ağuşunu açmış duruyor Peygamber "

Bütün şehitlerimizin ruhu şâd olsun, inanıyoruz ki kanları yerde kalmayacaktır.
*******************************************************

Sorum şu, yardımcı olacak arkadaşlara şimdiden teşekkürler.

mevcut listemden bazı kriterlere göre yeniden bir listeleme yapmak istiyorum. Ekteki dosya üzerinden yardımlarınızı rica ediyorum.

 

[Orion1]

Ekli dosyayı inceleyiniz.
Otomatik filtre uygulandı.

 

[ycimen]

Sayın Orion ilginize teşekkür ederim. Ama kullanmakta olduğum sayfada süzme işlemi yapmak benim için pek uygun değil. Bunun makro ile yapılması neredeyse şart.

 

[Orion1]

Sayın Orion ilginize teşekkür ederim. Ama kullanmakta olduğum sayfada süzme işlemi yapmak benim için pek uygun değil. Bunun makro ile yapılması neredeyse şart.

Ekli dosyayı inceleyiniz.
Sayfa2'ye aktarıyor.

Private Sub CommandButton1_Click()
Dim i, sat As Long
Sheets("Sayfa1").Select
Set s2 = Sheets("Sayfa2")
sat = 2
Application.ScreenUpdating = False
s2.Range("A2:E65536").ClearContents
Dim ilk_tarih, son_tarih As Date
If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then
    MsgBox "Geçerli bir tarih giriniz..!!", vbCritical
    TextBox1.SetFocus
    Exit Sub
End If
ilk_tarih = TextBox1.Value
son_tarih = TextBox2.Value
For i = 2 To Cells(65536, "A").End(xlUp).Row
    If CDate(Cells(i, "A").Value) >= ilk_tarih And CDate(Cells(i, "A").Value) <= son_tarih Then
        For k = 2 To 5
            s2.Cells(sat, k).Value = Cells(i, k).Value
        Next k
    End If
    sat = sat + 1
Next i
Application.ScreenUpdating = True
MsgBox "SAYFA2'YE AKTARMA TAMAMLANDI..!!", vbOKOnly + vbInformation
End Sub

 

[ycimen]

Sayn Orion,

Son öneriniz istediğime bir adım daha yaklaşmış olmakla beraber bazı eksiklikler var. Aynı modelleri alt alta tekralamasına gerek yok. Mesela, N 1110 bir kere gösterilip karşısındaki adet ve ücretlerin toplamı yer almalı. Ayrı bir sayfaya değil, örnekteki gibi mevcut sayfanın altına yapmalı. Ve bütün bunları oluşturulması istenen yeni listenin (rapor diyelim) hemen üstünde yer alan iki farklı hücredeki tarihler arası için yapmalı. Teşekkürler.

 

[Orion1]

Ekli dosyayı inceleyiniz.
Rapor butonuna basınız.

 

[Recep İpek]

Sonuçların ayrı bir sayfada olması daha uygun.

Buna göre yapılmış ekli dosyayı inceleyebilirsiniz.

Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("VERİ")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:f" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 6)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If CDate(a(i, 1)) >= CDate([K2]) And CDate(a(i, 1)) <= CDate([L2]) Then
            If Not IsEmpty(a(i, 3)) Then
                If Not .exists(a(i, 3)) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 2)
                    b(n, 3) = a(i, 3)
                    .Add a(i, 3), n
                    b(n, 6) = a(i, 6)
                End If
                b(.Item(a(i, 3)), 4) = b(.Item(a(i, 3)), 4) + 1
                b(.Item(a(i, 3)), 5) = b(.Item(a(i, 3)), 5) + a(i, 5)
            End If
        End If
    Next
End With
s2.Range("a2:f5000").ClearContents
s2.[a2].Resize(n, 6).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[ycimen]

TeŞekÜrler Sayin Rİpek.