tarih aralığında 2 kritere ve malzeme koduna göre rapor almak

a_self_lion · 23 Ekim 2007

Selam Arkadaşlar;

Siz değerli arkadaşlarımın yardımı ile Başımın çok dertte olduğu Gatecileri sonunda mağlup edeceğim. Bütün giriş işlemlerimi bitirdim ve sıra rapor almaya geldi. Bitince biraz daha düzeltip Foruma ekeleyeceğim ki benim gibi dertte olanların sıkıntıları azalsın.

Şimdi Soruma gelelim

Yapmak istediğim;

1- B sutununda bulunan Tarih aralığı benim seçtiğim User formda iki tarih arasındaki verileri alarak b sutunda bunları süzecek
SONRA
2- E sutununda bulunan MLZ_KOD ları nı giriş sırasından başlayarak aynılarının ve G sutunda bulunan SAYI değeri de aynı ise RAPOR Sayfasında A sutununa G sutunundaki Sayı Değeri de B sutununa H sutunundaki verileri toplatarak mlz kodlarını RAPOR Sayfasında C sutununa I sutunu değerlerini toplatarak Rapor sayfasında E sutununa yazdırmam gerekiyor
Anlatabildim acaba derdimi inşallah anlatabilmişimdi.
Sanırım biraz karışık ama aslında çok kolay

Ben Rapor sayfasına olması gerekenleri yazıcağım örnek olarak

Örnek dosyamı ekte gönderiyorum gerekli açıklamalr orda da vardır.

Saygılarımla,

Teşekkürler.

a_self_lion · 24 Ekim 2007

Dim a, i As Long, b(), n As Long
Set s1 = Sheets("veri")
Set s2 = Sheets("Rapor2")
With s1.Range("a2:j" & s1.[a65536].End(3).Row).Resize(, 10) ' veri sayfasındaki a2 ile
' a kolonundaki son satırdan sağdaki 10 kolon
a = .Value ' a değişkenine atanıyor.
ReDim b(1 To UBound(a, 1), 1 To 8)
End With
With CreateObject("scripting.dictionary") ' dictionary nesnesi oluşturuluyor.
.comparemode = vbTextCompare
For i = 1 To UBound(a, 1)
If CDate(a(i, 2)) >= CDate([k2]) And CDate(a(i, 2)) >= CDate([L2]) Then ' a değişkenindeki
' 2. kolonun tarihi belirttiğiniz tarih aralığında ise

If Not .exists(a(i, 4)) Then ' ve a değişkenindeki 4. kolon malzeme kodu yok ise, yani teke düşürüyoruz.
n = n + 1
b(n, 1) = n ' Dizinin 1.elemanına Sıra No
b(n, 2) = a(i, 4) 'Dizinin 2.elemanına Malzeme Kodu
.Add a(i, 4), n 'Dictionary nesnesine kontrol için Malzeme No
b(n, 3) = a(i, 5) 'Dizinin 3 elemanına Malzeme Adı
End If
b(.Item(a(i, 4)), 4) = b(.Item(a(i, 4)), 4) + a(i, 7) 'malzeme kodu var ise l ise
b(.Item(a(i, 4)), 5) = b(.Item(a(i, 4)), 5) + a(i, 10) ' diğer alanların toplamını alıyoruz.
b(.Item(a(i, 4)), 6) = b(.Item(a(i, 4)), 6) + a(i, 11) '....
b(.Item(a(i, 4)), 7) = b(.Item(a(i, 4)), 7) + a(i, 12)
b(.Item(a(i, 4)), 8) = b(.Item(a(i, 4)), 8) + a(i, 13)
End If
Next
End With
s2.Range("a2:m" & s2.[a65536].End(3).Row).Resize(, 8).ClearContents
s2.[a2].Resize(n, 8).Value = b
MsgBox "Bitti"
s2.Select
[a1].Select
Set s1 = Nothing
Set s2 = Nothing

Bu kodlar la mlz_koduna göre istediğime yakın bir sıralama alabiliyorum ama burda devreye giren Sayı sutunu var orda da hem mlz_kodu tutacak hemde sayısı tutatcak sa toplamları alacak işte bunu beceremedim.

a_self_lion · 25 Ekim 2007

Sevgili Arkadaşlar açaba bu düşündüğüm gibi bir rapor almak mümkün mü?

veya farklı bir çözüm almak için yorumlarınızda olabilir.

mrttrn · 25 Ekim 2007

Sn a_self_lion;
veri sayfası yanında, rapor1,rapor2,rapor3 sayfası oluşturdum.
Commandbutton1 tıkla.İstenen sonuç rapor3 sayfasında.
Bayağı uğraştım.İleride benim de işime yarayacak.
Kendimce çözüm bulmaya çalıştım.İnşallah işine yarar.Kodları kontrol et.

Kod:

Private Sub CommandButton1_Click()
   Dim a
    Set VR = Worksheets("veri")
    Set RP2 = Worksheets("rapor2")
    Set RP3 = Worksheets("rapor3")
'-------------------------------------------------------------
 '1.ADIM:veri sayfasının aynısı rapor2 sayfasına kopyalanıyor.
 VR.Range("A2").CurrentRegion.Copy RP2.Range("A1") 'Hücre biçimleriyle kopyalama.
 RP2.[a:z].EntireColumn.AutoFit 'Tüm sutunları uygun genişliğe getir.
 RP2.Select
 satır = WorksheetFunction.CountA(Range("B:B"))
'-------------------------------------------------------------
'2.ADIM: İki tarih arasında olmayan satırlar siliniyor.
   For i = satır To 2 Step -1  'Son elemandan, 2 ye kadar 1 er eksiltme.
     If DateValue(TextBox2) < RP2.Range("B" & i) Then
        RP2.Rows(i).Delete 'satırı sil
     Else
        If DateValue(TextBox1) > RP2.Range("B" & i) Then
           a = RP2.Range("B" & i)
           RP2.Rows(i).Delete 'satırı sil
         End If
     End If
   Next
'-------------------------------------------------------------------------
'3.ADIM: Tekrar edenler toplanıyor.rapor2 deki istenmeyen sutunlar siliniyor.
   RP2.Columns(10).Delete 'j SUTUNU YOKET.
   RP2.Columns(1).Delete 'A sutunu yoket.
   RP2.Columns(1).Delete 'B sutunu yoket.
   RP2.Columns(1).Delete 'C sutunu yoket.
   RP2.Columns(1).Delete 'D sutunu yoket.
   RP2.Columns(1).Delete 'E sutunu yoket.
'-------------------------------------------------------------------------
''4.ADIM: Tekrar edenler toplanıyor.Ve rapor3 e aktarılıyor.
RP3.Select
RP3.Range("A:D").Clear
RP3.Range("A1:D1") = VR.Range("F1:I1").Value

Do
 RP2.Select
 RP2.Range("A2").AutoFilter field:=1, Criteria1:=RP2.Range("A2") 'Otomatik süz A2 verisi
 RP2.Range("E1").FormulaR1C1 = "=SUBTOTAL(9,R[1]C[-2]:R[10000]C[-2])" 'ALTTOPLAM(9;C2:C10000)
  'ALTTOPLAM görünen satırları toplar.Gizli satırları toplamaya eklemez.
 RP2.Range("F1").FormulaR1C1 = "=SUBTOTAL(9,R[1]C[-2]:R[10000]C[-2])" 'ALTTOPLAM(9;D2:D10000)
 
 RP3.Select 'Son raporda en alta eklenir.
 sırano = WorksheetFunction.CountA(RP3.Range("A:A"))
 RP3.Range("A" & sırano + 1) = RP2.Range("A2") 'MLZ_ADI
 RP3.Range("B" & sırano + 1) = RP2.Range("B2") 'SAYI
 RP3.Range("C" & sırano + 1) = RP2.Range("E1") 'GELEN
 RP3.Range("D" & sırano + 1) = RP2.Range("F1") 'İADE
 
 RP2.Select
 RP2.Range("A2").CurrentRegion.Select ' Dolu hücreleri seç.
 RP2.Range("A1").CurrentRegion.Delete shift:=xlUp 'Dolu hücreleri sil
 RP2.[A1].EntireRow.Insert
 RP2.Range("A1:D1") = VR.Range("F1:I1").Value
 
Loop While WorksheetFunction.CountA(RP2.Range("A:A")) > 1
 
RP3.Select
End Sub

Recep İpek · 26 Ekim 2007

Aşağıdaki kodları deneyiniz.

Kod:

[COLOR=blue]Private Sub[/COLOR] CommandButton1_Click[COLOR=blue]()[/COLOR]
[COLOR=blue]Dim[/COLOR] a, i, n, k, b()
[COLOR=blue]Set[/COLOR] s1 = Sheets("veri")
[COLOR=blue]Set[/COLOR] s2 = Sheets("rapor")
'*******************************************
a = s1.Range("a2:j" & s1.[a65536].End(3).Row).Value
[COLOR=blue]ReDim[/COLOR] b(1 To UBound(a, 1), 1 To 5)
With CreateObject[COLOR=blue]("Scripting.Dictionary")[/COLOR]
    .CompareMode = [COLOR=blue]vbTextCompare[/COLOR]
    For i = 1 To [COLOR=blue]UBound[/COLOR](a, 1)
        If [COLOR=blue]CDate[/COLOR](a(i, 2)) >= [COLOR=blue]CDate[/COLOR](TextBox1) And [COLOR=blue]CDate[/COLOR](a(i, 2)) <= [COLOR=blue]CDate[/COLOR](TextBox2) Then
            If Not [COLOR=blue]IsEmpty[/COLOR](a(i, 5)) Then
                If Not .exists(a(i, 5)) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 6)
                    b(n, 3) = a(i, 7)
                    .Add a(i, 5), n
                End If
                    b(.Item(a(i, 5)), 4) = b(.Item(a(i, 5)), 4) + a(i, 8)
                    b(.Item(a(i, 5)), 5) = b(.Item(a(i, 5)), 5) + a(i, 9)
            End If
        End If
    Next
End With
s2.Range("a2:e500").ClearContents
s2.[a2].Resize(n, 5).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
[COLOR=blue]Set[/COLOR] s1 = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]Set[/COLOR] s2 = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]End Sub[/COLOR]

a_self_lion · 26 Ekim 2007

Sayın mrttrn vbmenu_register("postmenu_210885", true); ilginiz için teşekkür ederim dediğiniz gibi yaptım ama istediğim gibi olmamış. mesela 684 Das Gold.Blaat 200741 5 1 şeklinde olmuş sizin yaptığınız kodlarda bunun bu şekilde değil dee

684 DAS GOLD.BLAAT 200741 2
684 DAS GOLD.BLAAT 200742 1
BILD GAZETESİ 071001 82 20
BILD GAZETESİ 071002 77 27
BILD GAZETESİ 071004

BİÇİMİNDE OLMASI LAZIM DAHA FAZLA ÖRNEK VERMEK GEREKİRSE

a_self_lion · 26 Ekim 2007

Sayın mrttrn vbmenu_register("postmenu_210885", true); ilginiz için teşekkür ederim dediğiniz gibi yaptım ama istediğim gibi olmamış. mesela sizin kodlarınızla çıkan sonuç bu şekilde olmuş

684 DAS GOLD.BLAAT 200741 3
BILD GAZTESİ 071001 475 132

Olması gereken ise bu aşağı yaptığım gibi olması lazımdı.

684 DAS GOLD.BLAAT 200741 2
684 DAS GOLD.BLAAT 200742 1
BILD GAZETESİ 071001 82 20
BILD GAZETESİ 071002 77 27
BILD GAZETESİ 071004 81 23
BILD GAZETESİ 071005 85 27
BILD GAZETESİ 071006 85 26
BILD GAZETESİ 071008 65 9

Dikkat etmemiz gereken bir şekilde de sayı sutundaki değerleride dikkate almamız lazım.

a_self_lion · 26 Ekim 2007

Sayın ripek ilginiz için teşekkür ederim

Sayı bölümü geliyor ekte tekrar size gönderiyorum dosyayı genel ve biraz daha detaylı bir açıklama yaptım olması gereken aşağıdaki ve size tekrar gönderdiğim örnekte açıkladığım gibi olması gerekiyor. bir yerlerde sanırım yine hata var.

684 DAS GOLD.BLAAT 200741 3
BILD GAZTESİ 071001 475 132

Olması gereken ise bu aşağı yaptığım gibi olması lazımdı.

684 DAS GOLD.BLAAT 200741 2
684 DAS GOLD.BLAAT 200742 1
BILD GAZETESİ 071001 82 20
BILD GAZETESİ 071002 77 27
BILD GAZETESİ 071004 81 23
BILD GAZETESİ 071005 85 27
BILD GAZETESİ 071006 85 26
BILD GAZETESİ 071008 65 9

Dikkat etmemiz gereken bir şekilde de sayı sutundaki değerleride dikkate almamız lazım.

Recep İpek · 26 Ekim 2007

Dosyanızı mümkünse .zip olarak gönderebilirmisiniz?

İşyerinde açamıyorum.

a_self_lion · 26 Ekim 2007

Dosyayı Zip olarak ekledim Sayın Ripek.

Recep İpek · 26 Ekim 2007

Kodları aşağıdaki şekilde değiştiriniz.

Kod:

[COLOR=blue]Private Sub[/COLOR] CommandButton1_[COLOR=blue]Click[/COLOR]()
Dim a, i, n, k, b(), z
Set s1 = Sheets("veri")
Set s2 = Sheets("rapor")
'*******************************************
a = s1.Range("a2:j" & s1.[a65536].End(3).Row).Value   'veri sayfas&#305;ndaki veriler a de&#287;i&#351;kenine tan&#305;mlan&#305;yor.
ReDim b(1 To UBound(a, 1), 1 To 5)  ' Dizinin boyutu belirleniyor.
With CreateObject("[COLOR=blue]Scripting.Dictionary[/COLOR]")  'Dictionary nesnesi yarat&#305;l&#305;yor.
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If [COLOR=blue]CDate[/COLOR](a(i, 2)) >= [COLOR=blue]CDate[/COLOR](TextBox1) And [COLOR=blue]CDate[/COLOR](a(i, 2)) <= [COLOR=blue]CDate[/COLOR](TextBox2) Then 'E&#287;er a de&#287;i&#351;keninin 2 verisi girilen tarihler aras&#305;nda ise
            If Not [COLOR=blue]IsEmpty[/COLOR](a(i, 7)) Then ' a de&#287;i&#351;keninin 7.eleman&#305; bo de&#287;il ise
                [COLOR=darkorchid]z [/COLOR]= a(i, 5) & ":" & a(i, 7) ' a de&#287;i&#351;keninin 5. ve 7. verilerini z'de birle&#351;tir.
                If Not .exists(z) Then  ' z de&#287;i&#351;keni yok ise
                    n = n + 1 
                    b(n, 1) = n ' Dizinin 1.eleman&#305; S&#305;ra No
                    b(n, 2) = a(i, 6)  'Dizinin 2.eleman&#305;  
                    b(n, 3) = a(i, 7)  'Dizinin 3.eleman&#305;
                    .Add z, n
                End If
                    b(.Item(z), 4) = b(.Item(z), 4) + a(i, 8)  ' Dizinin 4.eleman&#305; a de&#287;i&#351;keninin 8 verisi toplan&#305;yor
                    b(.Item(z), 5) = b(.Item(z), 5) + a(i, 9) ' Dizinin 4.eleman&#305; a de&#287;i&#351;keninin 9 verisi toplan&#305;yor
            End If
        End If
    Next
End With
s2.Range("a2:e500").ClearContents
s2.[a2].Resize(n, 5).Value = b ' Dizi Sayfa2'ye kopyalan&#305;yor.
'*******************************************
s2.[b2].Resize(n, 5).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("B2").Select ' S&#305;ralan&#305;yor.
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = [COLOR=blue]Nothing[/COLOR]
Set s2 = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]End Sub[/COLOR]

bono · 26 Ekim 2007

Arkadaşlar öncelikle bu çalışma (değiştirerekte olsa) benimde işime çok yaradı. Sorana da , vba kodunu yazana da çok teşekkür ederim. Eminim bir çok arkadaşımızında işine yarayacaktır

svg

a_self_lion · 26 Ekim 2007

Sayın Ripek gerçekten çok teşekkür ederim ilk denememi yaptım ve tam istediğim gibi olduğunu gördüm inşallah sorunsuz kullanırım.
Bütün çalışmamı bitirip foruma ekleyeceğim. Diğer arkadaşlarında çok işine yarayacağı kanısındayım. özellikle Benim gibi Gazetecilerle dertte olanlar için.

Sizden birşey rica edeceğim kodların ne işe yaradıklarına dair açıklama yazabilirseniz bu tür diğer çalışmalarımızda da bilinçli olarak kullanabiliriz. Ve kendimizi daha iyi geliştirmemize olanak verir. Tabi vaktiniz olursa.

Çok teşekkür ederim tekrar. Elinize sağlık. Allah işinizi rasgetirsin her zaman.

Recep İpek · 26 Ekim 2007

Gerekli açıklamaları yazmaya çalıştım.

Umarım faydalı olur.

a_self_lion · 26 Ekim 2007

Tekrar tekrar teşekkür ederim Sayın Ripek. Faydalı olmak ne demek. İlaç gibi geldi. Kafamda tasarladığım ama yapamam dediğim bir çok projem vardı karanlık bölgelerin bir çoğuna ışık tuttunuz.Başarılarınız devamını dilerim.