Scripting.Dictionary nesnesi hakkında

[Ziynettin]

İkiTarihMizan sayfasında [C:N] aralığını listeler.

Private Sub CommandButton1_Click()
Z = TimeValue(Now)
Application.ScreenUpdating = False
Set s1 = Sheets("Yevmiye")
Set s2 = Sheets("İkiTarihMizan")
Set d = CreateObject("scripting.dictionary")
ss1 = s1.Cells(Rows.Count, 1).End(xlUp).Row
ss2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
trh1 = CDate(s2.[A1])
trh2 = CDate(s2.[A2])
a = s1.Range("A2:U" & ss1)
ReDim b(1 To UBound(a), 1 To 12)

For i = 1 To UBound(a)
    If a(i, 2) >= trh1 And a(i, 2) <= trh2 Then
        veri = a(i, 4)
        If Not d.exists(veri) Then
            say = say + 1
            d(a(i, 4)) = say
            If Len(veri) >= 3 Then b(say, 1) = Left((veri), 3)
            If Len(veri) >= 6 Then b(say, 2) = Left((veri), 6)
            If Len(veri) >= 7 Then b(say, 3) = Left((veri), 7)
            If Len(veri) >= 9 Then b(say, 4) = Left(veri, 9)
            If Len(veri) >= 10 Then b(say, 5) = Left(veri, 10)
            If Len(veri) >= 11 Then b(say, 6) = Left(veri, 11)
        End If
        sat = d(a(i, 4))
        b(sat, 7) = b(sat, 7) + a(i, 7) ' Borç
        b(sat, 8) = b(sat, 8) + a(i, 8) ' Alacak
        b(sat, 9) = b(sat, 9) + a(i, 11) ' Doviz Borç
        b(sat, 10) = b(sat, 10) + a(i, 12) ' Doviz Alacak
        b(sat, 11) = b(sat, 11) + a(i, 16) ' T-U Borç
        b(sat, 12) = b(sat, 12) + a(i, 17) ' T-U Alacak
    End If
Next i
'****************************************************************

tbl = Array(b)
Erase b
d.RemoveAll
ReDim b(1 To say * 2, 1 To 7)

For i = 1 To say
    For j = 1 To 6
        veri = CStr(tbl(0)(i, j))
        If Not IsEmpty(veri) Then
            If Not d.exists(veri) Then
                say1 = say1 + 1
                d(veri) = say1
                b(say1, 1) = CStr(veri)
            End If
            b(d(veri), 2) = b(d(veri), 2) + tbl(0)(i, 7) ' Borç
            b(d(veri), 3) = b(d(veri), 3) + tbl(0)(i, 8) ' Alacak
            b(d(veri), 4) = b(d(veri), 4) + tbl(0)(i, 9) ' Doviz Borç
            b(d(veri), 5) = b(d(veri), 5) + tbl(0)(i, 10) ' Doviz Alacak
            b(d(veri), 6) = b(d(veri), 6) + tbl(0)(i, 11) ' T-U Borç
            b(d(veri), 7) = b(d(veri), 7) + tbl(0)(i, 12) ' T-U Alacak
        End If
    Next j
Next i
'****************************************************************

k = s2.Range("A4:A" & ss2)
On Error Resume Next
ReDim c(1 To UBound(k), 1 To 12)

For i = 1 To UBound(k)
    n = n + 1
    For y = 1 To 12: c(i, y) = 0: Next y
    
    c(n, 1) = b(d(CStr(k(i, 1))), 2) 'Borç -C
    c(n, 2) = b(d(CStr(k(i, 1))), 3) 'Alacak -D
        If b(d(CStr(k(i, 1))), 2) > b(d(CStr(k(i, 1))), 3) Then
            c(n, 3) = b(d(CStr(k(i, 1))), 2) - b(d(CStr(k(i, 1))), 3) 'Bakiye Borç -E
        Else
            c(n, 4) = b(d(CStr(k(i, 1))), 3) - b(d(CStr(k(i, 1))), 2) 'Bakiye Alacak -F
        End If
        
    c(n, 5) = b(d(CStr(k(i, 1))), 4) 'Döviz Borç -G
    c(n, 6) = b(d(CStr(k(i, 1))), 5) 'Döviz Alacak -H
        If b(d(CStr(k(i, 1))), 4) > b(d(CStr(k(i, 1))), 5) Then
            c(n, 7) = b(d(CStr(k(i, 1))), 4) - b(d(CStr(k(i, 1))), 5) 'Dvz. Bakiye Borç -I
        Else
            c(n, 8) = b(d(CStr(k(i, 1))), 5) - b(d(CStr(k(i, 1))), 4) 'Dvz. Bakiye Alacak -J
        End If
        
    c(n, 9) = b(d(CStr(k(i, 1))), 6) 'T-U Borç -K
    c(n, 10) = b(d(CStr(k(i, 1))), 7) 'T-U Alacak -L
        If b(d(CStr(k(i, 1))), 6) > b(d(CStr(k(i, 1))), 7) Then
            c(n, 11) = b(d(CStr(k(i, 1))), 6) - b(d(CStr(k(i, 1))), 7) 'T-U Brc Bky -M
        Else
            c(n, 12) = b(d(CStr(k(i, 1))), 7) - b(d(CStr(k(i, 1))), 6) 'T-U Alc Bky -N
        End If
        
Next i
'*************************************************************************

s2.[C4].Resize(n, 12) = c
s2.[C4].Resize(n, 12).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True
MsgBox CDate(TimeValue(Now) - Z)
End Sub

https://www.dosyaupload.com/54xo

 

[KarıncaZ]

Merhaba Sayın Ziynettin

Yardımlarınız için çok teşekkürler.

T-U Borç Alacak kısımlarını hepsini 0,00 olarak getiriyor ancak diğer alanlar doğru. Diğer alanlara bakarak gerekli düzeltmeleri yaparım.

scripting nesneleri ile ilgili internette aradığım kaynaklar genelde hep ingilizce. Bu konuyu tüm detaylarıyla öğrene bileceğim bir kaynak yada yol önere bilir misiniz.Veri analizleri için çok işime yarayacağı kesin. Bu nedenle konuyu iyi düzeyde öğrenmem gerekiyor. Yapabildiğim kodlamalar, veri sayısı arttıkça yetersiz ve verimsiz kalıyor.

Yardımlarınız için tekrar teşekkür ederim. Esenlikler dilerim. İyi çalışmalar.


Esenlikler dilerim. İyi çalışmalar.

 

[Ziynettin]

T-U Borç Alacak kısımlarını hepsini 0,00 olarak getiriyor

T-U borç (K sütunu) kısmına Yevmiye P sütunundaki değerleri toplar.
Aranan tarih aralığında P sütununda değer olup olmadığını kontrol ediniz.

 

[walabi]

Aşağıdaki kod ise tek sütundaki benzersizleri listelerken ikinci sütundaki verileri toplayarak rapor oluşturur. Yani bir nevi özet tablo gibi çalışır.

Sub BENZERSİZ_TEK_SÜTUN_TOPLAMALI()
    Dim s As Object, liste(), dizi()
  
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
  
    ReDim dizi(1 To Son, 1 To 1)
  
    Set s = CreateObject("Scripting.Dictionary")
  
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1)
        If Not s.exists(Aranan) Then
            Say = Say + 1
            s.Add Aranan, Say
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
        End If
        dizi(s.Item(Aranan), 2) = dizi(s.Item(Aranan), 2) + liste(i, 2)
    Next i
  
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub

Korhan Beyin daha önce cevaplamış olduğu bu kodların bir benzerini kendi dosyamda uygulamak istedim, ancak dizi mantığını halada çözemedim sanırım.

İki sütunlu veriyi benzersiz olarak birbaşka sayfaya yazdırıp, bu yazdırılan satırların yanlarına da çoketopla mantığı ile birden fazla sütunun, miktar, tutar gibi sayısal değerlerini toplatmak istedim. Ancak ben yapamadım. Bunu yapabilmek için kodlar nasıl olmalıdır. Aşağıda kendi dosyama uyarlamaya çalıştığım kodlar var. Alıntı.

Temel olarak yapmak istediğim şey şu. Bir veri sayfasında Malzeme Adı ve Malzeme Kodu sütunlarını benzersiz olarak bir başka sayfaya yazdırıp ilgili malzemeye ait, miktarları, tutarları vb sayısal değerleri yanyana ilgili sütunlarda toplatmak. Rapor adlı bir sayfa düşünürsek;
A Sütunu: Malzeme Adı
B Sütunu: Malzeme Kodu
C Sütunu: Adet
D Sütunu: Tutar

gibi şeklinde , bu şekilde yapabilmek için kod nasıl olmalı.

Sub BENZERSİZ_TEK_SÜTUN_TOPLAMALI()
    Dim s As Object, liste(), dizi()
   
    'Son = Sheets("Detaylı_Alış_Faturaları").Cells(Rows.Count, "A").End(3).Row
    Son = Sheets("xxx").Cells(Rows.Count, "A").End(3).Row
    'liste = Sheets("Detaylı_Alış_Faturaları").Range("N2:N" & Son).Value
    liste = Sheets("xxx").Range("N2:P" & Son).Value
   
   
    Sheets("Rapor2").Range("A:Z").Clear
    Sheets("Rapor2").Range("a1") = "Malzeme Adı"
    Sheets("Rapor2").Range("b1") = "Malzeme Kodu"
    Sheets("Rapor2").Range("c1") = "Miktar"
   
   
    ReDim dizi(1 To Son, 1 To 1)
   
    Set s = CreateObject("Scripting.Dictionary")
   
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1) & liste(i, 2)
        Aranan2 = liste(i, 3)
        If Not s.exists(Aranan) Then
            Say = Say + 1
            s.Add Aranan, Say
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
           
        End If
        dizi(s.Item(Aranan2), 2) = dizi(s.Item(Aranan2), 2) + liste(i, 3)
    Next i
   
    Sheets("Rapor2").Range("A2").Resize(s.Count, 2) = dizi
End Sub

 

[Korhan Ayhan]

Öncelikle kod yazarken tanımlamaları kullanmanızı alışkanlık haline getirmenizi ısrarla tavsiye ederim.

Örnek olarak sayfa ismi kullandığınız tüm satırlarda Sheets("Detaylı_Alış_Faturaları") şeklinde uzun uzun yazmak bir müddet sonra can sıkıcı olacaktır.

Bunun yerine daha önce forumda farklı başlıklarda paylaştığımız kodlarda belki görmüşsünüzdür. Aşağıdaki şekilde kodun en başında bu tür değişkenleri yanımlarsanız daha sonraki satırlarda yazarken sizin için büyük kolaylık olacaktır.

Dim S1 As Worksheet
Set S1 = Sheets("Detaylı_Alış_Faturaları")

Hem sorunuza cevap olması açısından hemde değişken tanımlama kullanımına örnek olması açısından linki inceleyebilirsiniz.

HÜCRELERİ BİRLEŞTİRME

Merhaba; Tabloda boyalı yerleri birleşmesini istiyorum. macro da olabilir. soldaki aynı irsaliye altında olan müşterinin birden fazla satırını tek satırda birleştirsin. irsaliye tutar, m3 ve desi toplamlarını birleştirsin. nasıl yapabilirim? https://www.hizliresim.com/prkj2ny dosya yada...

www.excel.web.tr

Linkteki makro bir nevi özet tablo (pivot table) mantığı ile çalışmaktadır. Yani tam sizin aradığınız makro kodlarıdır.