Şartlı özet rapor

[Warner]

arkadaşlar ekli dosyanın içinde herşeyi anlattım.
Yardımcı olursanız çok sevinirim

 

[Ömer]

arkadaşlar ekli dosyanın içinde herşeyi anlattım.
Yardımcı olursanız çok sevinirim

Merhaba,

Module kopyalayıp çalıştırın. C,D ve E sütununa istediğiniz raporlamayı yapacaktır. Yalnız kodu çalıştırmadan önce birleştirdiğiniz açıklama hücrelerini, birleştirmelerini kaldırarak siliniz, çünkü raporlamanın bir bölümü E sütunu kapsamaktadır.

Sub SartliRapor()
 
    Dim d As Object, i As Long, sat As Long, n As Byte, deg, a1, a2, s
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
    Range("C3:E" & Rows.Count).ClearContents
    Range("C2") = "Döküm No": Range("D2") = "Adet": Range("E2") = "B.Adet"
 
    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        n = 0
        If Not d.exists(deg) Then
            If Cells(i, "A").Interior.ColorIndex = 6 Then n = 1
            s = Array(1, n)
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(0) = s(0) + 1
            If Cells(i, "A").Interior.ColorIndex = 6 Then s(1) = s(1) + 1
            d.Item(deg) = s
        End If
    Next i
 
    a1 = d.keys: a2 = d.items: sat = 3
    For i = 0 To d.Count - 1
        Cells(i + sat, "C") = a1(i)
        s = a2(i)
        Cells(i + sat, "D") = s(0)
        Cells(i + sat, "E") = s(1)
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Warner]

Ömer Kardeşim bana bir telefonunu versene senin yüzüne karşı bir teşekkür etmek istiyorum
çok iyisin teşekkürler

 

[Warner]

Peki Ardaşık giden Br Numaralarının arasına Uyarı koyabilirmiyiz.
Mesela 15 nolu numuneden test alındı 65 numunedir hiç test alınmamış 50 numune sonra uyarı verebilirmi.65 nolu br'den test alımamıştır.50+50+50 Periyod.Değişimli periyod.ben o limiti verebileyim.Bugün 50 periyodda bir yarın başka üretimde 100 periyotta bir...Teşekkürler

 

[Warner]

Ömer bey

ömer bey bu konu hakkındada yardımcı olursanız çok sevinirim

 

[Ömer]

Bu şekilde soruyu anlayamadım. Örnek dosya üzerinde detaylı açıklarmısınız.

 

[Warner]

yazdım ömerbey ekte...

 

[Ömer]

Nasıl bir uyarı. Eğer test aralığı 50 yi geçerse kodlar uyarı verip daha sonra hiç bir işlem yapmayacak mı?

 

[Warner]

dün yaptığımızkodların yanında bu extrası.
Mesela alınan testin ardından 50 boru geçtiyse alınması gereken numara kırmızı olabilir.
Birde 25-50-100 bu periyodu belirleyeceğim bir yer olursa süper olur

 

[Ömer]

dün yaptığımızkodların yanında bu extrası.
Mesela alınan testin ardından 50 boru geçtiyse alınması gereken numara kırmızı olabilir.
Birde 25-50-100 bu periyodu belirleyeceğim bir yer olursa süper olur

Kodları aşağıdakilerle değiştirin.

Sub SartliRapor()
 
    Dim d As Object, i As Long, sat As Long, n As Byte, say As Long, deg, a1, a2, s, sor

 
    Set d = CreateObject("Scripting.Dictionary")
 
    On Error Resume Next
    sor = Application.InputBox("Periyod Sayısı Girin", "Dikkat!")
    If sor = "" Or sor = 0 Then Exit Sub
 
    Application.ScreenUpdating = False
    Range("C3:E" & Rows.Count).ClearContents
    Range("C2") = "Döküm No": Range("D2") = "Adet": Range("E2") = "B.Adet"
 
    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
        say = say + 1
        deg = Cells(i, "B")
        n = 0
        If Not d.exists(deg) Then
            If Cells(i, "A").Interior.ColorIndex = 6 Then n = 1
            s = Array(1, n)
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(0) = s(0) + 1
            If Cells(i, "A").Interior.ColorIndex = 6 Then s(1) = s(1) + 1
            d.Item(deg) = s
        End If
        If say Mod sor = 1 And say <> 1 Then Cells(i, "A").Interior.ColorIndex = 3: say = 0
        If Cells(i, "A").Interior.ColorIndex = 6 Then say = 0
    Next i
 
    a1 = d.keys: a2 = d.items: sat = 3
    For i = 0 To d.Count - 1
        Cells(i + sat, "C") = a1(i)
        s = a2(i)
        Cells(i + sat, "D") = s(0)
        Cells(i + sat, "E") = s(1)
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Warner]

ömer bey

çok teşekkkür ederim 10Numara olmuş

ben sizin başınızı zaman zaman ağrıtsam ayıp olmaz dimi.

 

[Ömer]

Rica ederim. Olmaz tabiki, yalnız konu bütünlüğünü korumak için farklı konularla ilgili sorularınız için yeni konu başlığı açarak sorunuzu yöneltmeniz daha doğru olur.

İyi çalışmalar.

 

[Warner]

Ömer bey Bu yapmış olduğumuz işlemde ilk br dan test alınmadığında kırmızı yanmıyor. periyodu 3 yazdığımdada 4 Br numarası kırmızı oluyor Düzelte bilirmiyiz

 

[Warner]

yokmu kimse