Şartlı Rapor Alma

[Barfly]

Veri sayfasından belirlenen şarta göre rapor almaya çalışıyorum, mutlaka sitede benzer uygulamalar vardır fakat bir türlü benzer bir çalışma bulamadım, konuyu dosyada izah etmeye çalıştım yardımcı olabilirseniz çok sevinirim.

Teşekkürler,

 

[Orion1]

Dosyanız ektedir.

Sub rapor_59()
Dim sh As Worksheet, sat1 As Long, sat2 As Long
Dim k As Range, adr As String
Sheets("RAPOR").Select
Application.ScreenUpdating = False
Range("A9:K" & Rows.Count).ClearContents
Set sh = Sheets("VERİ")
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set k = sh.Range("A2:A" & sat2).Find(Range("B1").Value, , xlValues, xlWhole)
sat1 = 9
If Not k Is Nothing Then
    adr = k.Address
    Do
        If sh.Cells(k.Row, "W").Value > 0 Then
            Cells(sat1, "A").Value = k.Value
            Cells(sat1, "B").Value = sh.Cells(k.Row, "B").Value
            Cells(sat1, "C").Value = sh.Cells(k.Row, "F").Value
            Cells(sat1, "D").Value = sh.Cells(k.Row, "I").Value
            Cells(sat1, "E").Value = sh.Cells(k.Row, "M").Value
            Cells(sat1, "F").Value = sh.Cells(k.Row, "O").Value
            Cells(sat1, "G").Value = sh.Cells(k.Row, "P").Value
            Cells(sat1, "H").Value = sh.Cells(k.Row, "K").Value
            Cells(sat1, "I").Value = sh.Cells(k.Row, "Y").Value
            Cells(sat1, "J").Value = sh.Cells(k.Row, "Z").Value
            Cells(sat1, "K").Value = sh.Cells(k.Row, "AA").Value
            sat1 = sat1 + 1
        End If
        Set k = sh.Range("A2:A" & sat2).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[İhsan Tank]

Veri sayfasından belirlenen şarta göre rapor almaya çalışıyorum, mutlaka sitede benzer uygulamalar vardır fakat bir türlü benzer bir çalışma bulamadım, konuyu dosyada izah etmeye çalıştım yardımcı olabilirseniz çok sevinirim.

Teşekkürler,

Merhaba
Alternatif Olsun ( Orion1 Hocama alternatif yazılmaz ama olsun ben yazdım )
Kodu boş bir module kopyalayın ve deneyin.

Option Explicit
Sub çıkış_haftaya_göre_bul_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
Dim bordo, mavi
Set bordo = Sheets("VERİ")
Set mavi = Sheets("RAPOR")
trabzonspor = MsgBox(mavi.Range("B1") & " Verilerini Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
mavi.Range("A9:K" & Rows.Count).ClearContents
kaplan = 9
Set ts = bordo.Range("A:A").Find(mavi.Range("B1"), , , xlWhole)
If Not ts Is Nothing Then
trabzonspor = ts.Address
Do
If bordo.Cells(ts.Row, "W") > 0 Then
mavi.Cells(kaplan, "A") = bordo.Cells(ts.Row, "A") 'Çıkış Haftası
mavi.Cells(kaplan, "B") = bordo.Cells(ts.Row, "B") 'Operasyoncu
mavi.Cells(kaplan, "C") = bordo.Cells(ts.Row, "F") 'Sipariş No
mavi.Cells(kaplan, "D") = bordo.Cells(ts.Row, "I") 'Sevk Tarihi
mavi.Cells(kaplan, "E") = bordo.Cells(ts.Row, "M") 'Müşteri Adı
mavi.Cells(kaplan, "F") = bordo.Cells(ts.Row, "O") 'Madde Adı
mavi.Cells(kaplan, "G") = bordo.Cells(ts.Row, "P") 'Paketleme Tipi
mavi.Cells(kaplan, "H") = bordo.Cells(ts.Row, "Q") 'Sipariş Miktar (KG)
mavi.Cells(kaplan, "I") = bordo.Cells(ts.Row, "Y") 'Teslim Şekli
mavi.Cells(kaplan, "J") = bordo.Cells(ts.Row, "Z") 'Yükleme Yeri
mavi.Cells(kaplan, "K") = bordo.Cells(ts.Row, "AA") 'Varış Yeri
kaplan = kaplan + 1
End If
Set ts = bordo.Range("A:A").FindNext(ts)
Loop While Not ts Is Nothing And ts.Address <> trabzonspor
End If
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& mavi.Range("B1") & " Verilerini Aktardım", , "Bitiş"
End Sub

 

[Barfly]

Ellerinize sağlık her iki kodu da inceliyorum, bu işlemi formülle yaptırmak mümkün olur muydu?

Teşekkürler,

 

[İhsan Tank]

Ellerinize sağlık her iki kodu da inceliyorum, bu işlemi formülle yaptırmak mümkün olur muydu?

Teşekkürler,

Evet formülle yapılır ama veriler arttıkça formüller dosyayı kasmaya başlar bu sebeple hem hocam Orion1 hemde ben makro kodu verdik.

 

[Barfly]

Yardımlarınız için çok teşekkür ederim, yukarıdaki sorularıma bir şey daha eklemek istedim, ekteki dosyada olduğu gibi aynı şarta göre tek sayfaya iki sayfadan veri almak istesem bunu yapmak mümkün müdür?

Teşekkürler,

 

[Barfly]

İhsan Hocam,
Sayın Orion1,

Yardımcı olabilirseniz çok sevinirim.

Teşekkürler,