Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Scripting.Dictionary nesnesi hakkında (http://www.excel.web.tr/showthread.php?t=146392)

kuvari 02-02-2015 12:50

Scripting.Dictionary nesnesi hakkında
 
1 Eklenti(ler)
Merhaba,

Scripting.Dictionary nesnesini öğrenmek için bir örnek çalışma yaptım, tek sütunda işlem yapmak istediğimde yapabildim ama işin içine 2 sütun girince yöntemini bulamadım. Yapmak istediğim sayfa1'de benzersiz olanları sayfa2'de listelemek.

İlave bir sorum daha olacak , Scripting.Dictionary 'de oluşan dizinin tek haneli olarak nasıl alabilirim.

s.Keys bütün verileri kapsıyor, sadece dizideki sıra numarası yazarak nasıl getirebilirim.

Korhan Ayhan 02-02-2015 13:34

İkinci sütundaki sayılar toplanacak mı? Yani bir nevi ÖZET TABLO gibi mi işlem yapılacak?

Yoksa iki sütuna göre benzersiz kayıtlarımı listelemek istiyor sunuz?

kuvari 02-02-2015 13:42

Alıntı:

Korhan Ayhan tarafından gönderildi (Mesaj 795271)
İkinci sütundaki sayılar toplanacak mı? Yani bir nevi ÖZET TABLO gibi mi işlem yapılacak?

Yoksa iki sütuna göre benzersiz kayıtlarımı listelemek istiyor sunuz?

Korhan üstad benzersiz kayıtları listelemek istiyorum.

Başka bir sayfada toplam olarakta aldırabilirsiniz. İkisinide görmüş olurum.

Korhan Ayhan 02-02-2015 13:47

Aşağıdaki kod çift sütuna göre benzersiz verileri listeler.

Kod:

Sub BENZERSİZ_ÇİFT_SÜTUN()
    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 2)
   
    Set s = CreateObject("Scripting.Dictionary")
   
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1) & liste(i, 2)
        If Not s.exists(Aranan) Then
            s.Add Aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        End If
    Next i
   
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub


Korhan Ayhan 02-02-2015 13:57

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.

Kod:

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


kuvari 02-02-2015 14:17

Hocam ellerinize sağlık, çok güzel başvuru kaynağı oldu benim için.

Hocam bir sorum daha vardı,Scripting.Dictionary dizinindeki sıra numarasına göre nasıl gösterebilirim, dizi (1) dediğimde dizinin birinci değerini getirmek gibi.

kuvari 02-02-2015 14:48

Korhan hocam bir sorum daha olacak. Sadece "a" ları listelemek isteseydim, nasıl kodlamak gerekirdi.

Korhan Ayhan 02-02-2015 16:02

Şimdilik aşağıdaki linki inceleyiniz. Bol bol örnek var.

http://www.snb-vba.eu/VBA_Dictionary_en.html

kuvari 02-02-2015 16:33

Korhan bey kaynak için sağolun,yine de sizden cevap bekliyorum.

kuvari 02-02-2015 17:01

Korhan bey sadece a'ları getirebildim ama Scripting.Dictionary nesnesine hiç ihtiyacım olmadı.

Aklıma takılan Scripting.Dictionary dizinindeki sıra numarasına göre nasıl gösterebilirim, dizi (1) dediğimde dizinin birinci değerini getirmek gibi

Kod:

Option Base 1
Sub BENZERSİZ_ÇİFT_SÜTUN()
On Error Resume Next
    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 2)
   
    Set s = CreateObject("Scripting.Dictionary")
   
    For i = 1 To UBound(liste, 1)
        aranan = liste(i, 1)
      If aranan = "a" Then
    '    If Not s.exists(aranan) Then
            s.Add aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        'End If
        End If
    Next i
   
    Sheets(2).Range("A2").Resize(UBound(dizi), 2) = (dizi)
End Sub


Ömer 02-02-2015 22:22

Merhaba,

MsgBox dizi(1, 2) 'dizinin 1. satır 2.sütunundaki elamanı.

İstediğiniz bu mu?

Korhan Ayhan 02-02-2015 23:08

Oluşan dizideki item değerlerine aşağıdaki gibi ulaşabilirsiniz.

Kod:

Sub Test()
    Dim d, a, i
   
    Set d = CreateObject("Scripting.Dictionary")
   
    d.Add "www", 1
    d.Add "excel", 2
    d.Add "web", 3
    d.Add "tr", 4
   
    a = d.Keys
   
    For i = 0 To d.Count - 1
        MsgBox a(i)
    Next
   
    Set d = Nothing
End Sub


Korhan Ayhan 02-02-2015 23:42

Dictionary listesi büyük veri yığınlarını çok hızlı bir şekilde derlemektedir. Bunu yaptığım testlerde gözlemledim.

Aşağıdaki kodu boş bir dosyada deneyiniz.

A sütununa 1 den 100.000 e kadar sıra numarası giriniz. Sonra kodu çalıştırıp süreyi gözlemleyiniz.

Daha sonra veri sayısını çoğaltarak süreyi test ediniz.

Ben İ7 işlemci ile 500.000 adet benzersiz veride 12 saniyede sonuç aldım. Benzer kayıt sayısı arttığında ise işlem süresi dahada kısalmaktadır.


Kod:

Sub Test()
    Dim Dizi, Liste, Zaman, Son, i
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    Liste = Range("A1:A" & Son)
   
    For i = 1 To UBound(Liste, 1)
        If Not Dizi.exists(Liste(i, 1)) Then
            Dizi.Add Liste(i, 1), Nothing
        End If
    Next
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Benzersiz kayıt sayısı : " & Dizi.Count & Chr(10) & _
          "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
   
    Set Dizi = Nothing
End Sub


kuvari 03-02-2015 12:09

Korhan bey çok sağolun, çok faydalı bilgiler veriyorsunuz.

Aşağıdaki kodda "a" ları listeledim ama Scripting.Dictionary'i işin içine sokamadım. Onu nasıl yapabilirim.

Kod:

Option Base 1
Sub BENZERSİZ_ÇİFT_SÜTUN()
On Error Resume Next
    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 2)
   
    Set s = CreateObject("Scripting.Dictionary")
   
    For i = 1 To UBound(liste, 1)
        aranan = liste(i, 1)
      If aranan = "a" Then
    '    If Not s.exists(aranan) Then
            s.Add aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        'End If
        End If
    Next i
   
    Sheets(2).Range("A2").Resize(UBound(dizi), 2) = (dizi)
End Sub


Korhan Ayhan 05-02-2015 02:27

Dictionary nesnesi verileri benzersiz mantığı ile biriktirir. Siz tekrar eden bir değere bakarak liste oluşturmak istiyorsunuz. Bu nedenle Dictionary nesnesini kullanmanıza gerek yok. Dizi yöntemiyle hızlıca sonuca gidebilirsiniz.

Kod:

Sub Test()
    Dim Liste(), Zaman, Son, Say, i
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Zaman = Timer
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    Liste = Range("A1:B" & Son)
   
    ReDim Veri(1 To Son, 1 To 2)
   
    For i = 1 To UBound(Liste, 1)
        If Liste(i, 1) = "a" Then
            Say = Say + 1
            ReDim Preserve Veri(1 To Son, 1 To 2)
            Veri(Say, 1) = Liste(i, 1)
            Veri(Say, 2) = Liste(i, 2)
        End If
    Next
   
    Range("E:F").ClearContents
    Range("E1").Resize(Say, 2) = Veri
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
End Sub


Ömer BARAN 08-02-2015 14:59

1 Eklenti(ler)
Alıntı:

Korhan Ayhan tarafından gönderildi (Mesaj 795276)
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.

Kod:

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


Merhabalar Sayın AYHAN, bu konudaki mesaj ve açıklamalardan anladığım
kadarıyla, benim derdimin çözümü de bu kodlardan geçiyor, birkaç eksiğine
rağmen sizlerin katkılarıyla oluşturduğum ekteki excel belgeme bir göz atabilir misiniz acaba?

Mevcut belgemde sonuç almam 100-110 saniye sürüyor.
Eğer sizin buradaki kodlarınızı kullanabilseydim birkaç saniyede sonuç alacağımı sanıyorum.

Ekteki excel belgesinin, birkaç gizli sayfa ve yerleşik fonksiyonları kullanan makroların
NİHAİ AMACI, TABLO1 sayfasında
-- E2 (veri doğrulama seçimine göre F4:AU4 aralığı oluşturuluyor),
--E3 (veri doğrulama seçimine göre F3:AU3 aralığı oluşturuluyor) VE
--E4
(veri doğrulama seçimine göre E8:E17 aralığı oluşturuluyor)
hücrelerindeki seçimlere göre oluşan tablo sütun ve satır başlıklarına göre LİSTE sayfasının;

1) koşullara uyan satırlarında, C sütunundaki
BENZERSİZ VERİ SAYIMININ,

2) koşullara uyan SATIR SAYIMININ

yapılması ve TABLO1 sayfasında satır ve sütun başlıklarına göre ilgili alanlara yazılması.

NOT : Belgemdeki mevcut makro ve sayfaların çalışma mantığını; LİSTE ve TABLO1 sayfalarındaki
METİN KUTULARINDA ve SEÇİM sayfası Q ve R sütunlarında elimden geldiğince anlaşılır şekilde açıkladım.

Ömer BARAN 14-02-2015 22:21

CreateObject("Scripting.Dictionary") yöntemini kullanarak, bir üstteki mesajımda yer alan belgemi açıp mevcut makro çalıştırıldığında alınan sonuçlara, çok kısa sürede ulaşılacağını düşündüğümden destek rica etmiştim.
Sayın AYHAN veya konuyu bilen bir üye ilgilenirse sevinirim.
Yapılacak işlem liste sayfası DR sütununda, TABLO1 sayfamdaki satır ve sütun başlıklarına göre ilgili sütunlardaki bilgiler, aralara " | " eklenerek metne dönüştürülmesi halinde (bu dönüştürme işlemi belgemdeki SAYIM2 makrosuna kadarki kısımda gerçekleşiyor) bulunduğu satırlarda C sütunundaki farklı değer sayısı ile eşleşmenin olduğu satır sayısının TABLO1 sayfasında F5 : AU17 aralığına yazdırılması gerekiyor.
Örnek dosyamda TABLO1 sayfasındaki düğme kullanılarak mevcut makrolar çalıştırıldığında oluşan makro sonuçlarından anlaşılacağını düşünüyorum.

Korhan Ayhan 17-02-2015 00:19

Merhaba Ömer Bey,

Eklemiş olduğunuz dosyanıza boş bir sayfa ekleyin. Adı "Sayfa1" olsun.

Daha sonra diğer sayfanızdan seçimlerinizi yaptıktan sonra aşağıdaki kodu deneyin.

Kod:

Option Explicit

Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Zaman As Double, Son As Long, Nesne As Object, Liste()
    Dim Sutun1 As String, Sutun2 As String, Sutun3 As String
    Dim X As Long, Kriter As String, Say As Long
    Dim Tablo As PivotTable, Sutun As PivotField
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
   
    Set S1 = Sheets("LİSTE")
    Set S2 = Sheets("TABLO1")
    Set S3 = Sheets("Sayfa1")
   
    S3.Cells.Clear
   
    On Error Resume Next
    Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Son = 0 Then Son = 100000
    On Error GoTo 0
   
    Sutun1 = S2.Range("AG2")
    Sutun2 = S2.Range("AH2")
    Sutun3 = S2.Range("AI2")
   
    S3.Range(S3.Cells(1, 1), S3.Cells(Son - 6, 1)) = S1.Range(S1.Cells(7, Sutun2), S1.Cells(Son, Sutun2)).Value2
    S3.Range(S3.Cells(1, 2), S3.Cells(Son - 6, 2)) = S1.Range(S1.Cells(7, Sutun1), S1.Cells(Son, Sutun1)).Value2
    S3.Range(S3.Cells(1, 3), S3.Cells(Son - 6, 3)) = S1.Range(S1.Cells(7, Sutun3), S1.Cells(Son, Sutun3)).Value2
    S3.Range(S3.Cells(1, 4), S3.Cells(Son - 6, 4)) = S1.Range(S1.Cells(7, 3), S1.Cells(Son, 3)).Value2

    Set Nesne = CreateObject("Scripting.Dictionary")

    Liste = S3.Range("A1").CurrentRegion.Resize(, 4).Value
    ReDim Dizi(1 To 4, 1 To 1)
   
    For X = 1 To UBound(Liste, 1)
        Kriter = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3) & "#" & Liste(X, 4)
        If Not Nesne.Exists(Kriter) Then
            Say = Say + 1
            Nesne.Add Kriter, Say
            ReDim Preserve Dizi(1 To 4, 1 To Say)
            Dizi(1, Say) = Liste(X, 1)
            Dizi(2, Say) = Liste(X, 2)
            Dizi(3, Say) = Liste(X, 3)
            Dizi(4, Say) = Liste(X, 4)
        End If
    Next
       
    S3.Range("A1").Select
    S3.Range("A1").Resize(Rows.Count, 4).ClearContents
    S3.Range("A1").Resize(Say, 4) = Application.Transpose(Dizi)
       
    Set Tablo = S3.PivotTableWizard(, , S3.Range("H1"))
    Set Sutun = Tablo.PivotFields(S3.Range("A1").Text)
    Sutun.Orientation = xlColumnField
    Set Sutun = Tablo.PivotFields(S3.Range("B1").Text)
    Sutun.Orientation = xlColumnField
    Set Sutun = Tablo.PivotFields(S3.Range("C1").Text)
    Sutun.Orientation = xlRowField
    Set Sutun = Tablo.PivotFields("Hasta No")
    Sutun.Orientation = xlDataField
    Sutun.Function = xlCount
   
    S3.Cells.EntireColumn.AutoFit

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000")
End Sub


KarıncaZ 09-11-2017 11:45

Scripting.Dictionary yardım.
 
Merhaba.

Konuyu araştırdım yazılanları da okudum ancak bir türlü yapamadım.
Linkdeki dosyada çalışan makroların Scripting.Dictionary ile yada daha hızlı sonuç verecek bir yöntemle yapılması mümkün mü?

Veri sayısı çok fazla. Ben verilerin yarısını ekleyerek örnek dosyayı hazırladım.

http://s5.dosya.tc/server5/v44sbr/Es...rlama.zip.html

İkiTarihMizan Sayfasında şekillere atadığım makroların kısa sürede gerçekleşmesi çok önemli. Benim yazdıklarımın sonuçlanması çok uzun sürüyor bazende excel yanıt vermediği için kapatmak zorunda kalıyorum. Yevmiye sayfasında şekillere atadığım makroların sonuçlanması nispeten kabul edile bilir sürede.

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

Ziynettin 11-11-2017 00:34

Merhaba,

İkiTarihMizan sayfasında [C, D, E, F] sütunları için kodu bu şekilde kullanın.

Kod:

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:M" & ss1)
ReDim b(1 To UBound(a), 1 To 8)

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)
        b(sat, 8) = b(sat, 8) + a(i, 8)
    End If
Next i
'****************************************************************

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

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)
            b(d(veri), 3) = b(d(veri), 3) + tbl(0)(i, 8)
        End If
    Next j
Next i
'****************************************************************

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

For i = 1 To UBound(k)
    n = n + 1
    c(n, 1) = 0
    c(n, 2) = 0
    c(n, 3) = 0
    c(n, 4) = 0
    c(n, 1) = b(d(CStr(k(i, 1))), 2)
    c(n, 2) = b(d(CStr(k(i, 1))), 3)
    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)
    Else
        c(n, 4) = b(d(CStr(k(i, 1))), 3) - b(d(CStr(k(i, 1))), 2)
    End If
Next i
'*************************************************************************

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


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

Ziynettin 11-11-2017 12:21

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


Kod:

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 16-11-2017 09:47

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 16-11-2017 11:24

Alıntı:

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.


Saat 13:25

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.