Makro ile Özet Tablo Oluşturmak

[ayaslica]

Merhaba,

Obey sütünlarında bulunan rakamların Store sütununda görmek istiyorum.Mesala 121 rakamından 3 tane 125 rakamından ise 2 tane count yapıp getirecek örnek özet tabloda Özet 2 de yer almaktadır.Açıklama kısmında ise konun açıklamalarını getirmek istiyorum.

http://s9.dosya.tc/server/65ete5/Ornek_Ozt.xlsx.html
1.sayfa
Store Obey Obey Obey Obey Obey Obey
A 121 35
B 122 42 35 5 93 45
C 121 4 125
D 35 9 15
E 42 8 121
F 8 3 125
G 152 105 5

2.sayfa
121 Sorunlu
125 sorunsuz
122 sevk
35 lem
42 A
152 B
5 C
93 D
45 E
9 F

3.sayfa özet

Obey Açıklama Store Count
121 Sorunlu 3
125 sorunsuz 2
122 sevk 1
35 lem 2
42 A 1
152 B 2
5 C 1
93 D 1
45 E 1
9 F 1

 

[Ömer]

Merhaba,

Küçük bir örnek dosya hazırlayıp, dosya içerisinde gerekli açıklamayı örneklendirerek açıklarsanız çözüme daha hızlı ve net ulaşabilirsiniz.

Dosyanızı herhangi bir dosya paylaşım sitesine yükleyebilirsiniz. http://dosya.tc/ gibi.

.

 

[ayaslica]

Teşekkürler


http://s9.dosya.tc/server/65ete5/Ornek_Ozt.xlsx.html

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Ozet_Say()
 
    Dim d As Object, i As Range, s(), deg, son_st As Long, son_sn As Integer
    Dim Sd As Worksheet, Sa As Worksheet, alan As Range, c As Range, a1, a2, k As Long

    Set Sd = Sheets("Data")
    Set Sa = Sheets("Açıklama")
    son_st = Sd.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    son_sn = Sd.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    Set d = CreateObject("Scripting.Dictionary")
    Set alan = Sd.Range(Sd.Cells(2, "B"), Sd.Cells(son_st, son_sn))

    For Each i In alan
        If i <> "" Then
            Set c = Sa.[A:A].Find(i, , xlValues, xlWhole)
            If Not c Is Nothing Then
                deg = i
                If Not d.exists(deg) Then
                    s = Array(1, Sa.Cells(c.Row, "B"))
                    d.Add deg, s
                Else
                    s = d.Item(deg)
                     s(0) = s(0) + 1
                    d.Item(deg) = s
                End If
            End If
        End If
    Next i
    
    Sheets("Özet").Select
    Range("A3:C" & Rows.Count).ClearContents
      
    a1 = d.keys: a2 = d.items
    For k = 0 To d.Count - 1
        Cells(k + 3, "A") = a1(k)
        s = a2(k)
        Cells(k + 3, "B") = s(1)
        Cells(k + 3, "C") = s(0)
    Next k

End Sub

.

 

[ayaslica]

Teşekkürler
kodu çalıştıramadım yüksek ihtimal bir yerde hata yaptım.zahmet olmaz ise excel üzerinden yapabilir misiniz.
Çok teşekkürler yardımlarınız için

 

[YUSUF44]

Makro şöyle kullanılır:
Kodları kopyalayın.
Dosyanızı açın.
İster Alt+F11 yapın ister sayfa sekmesine sağ tıklayıp Kod Görüntüle deyin.
Insert Menüsünden Module'yi seçin
Kodları açılan sayfaya yapıştırın

Excel sayfanıza bir resim/şekil/nesne/düğme ekleyin
Eklediğinize sağ tıklayıp Makro Ata deyin
Çıkan menüde Ozet_Say makrosunu seçin

Excel dosyanızı Farklı kaydet ile Makro İçerebilen Excel Dosyası olarak kaydedin.

Bundan sonra o eklediğiniz şekil/nesne/düğmeye her bastığınızda makro çalışacaktır.

 

[ayaslica]

çok teşekkürler