Çok satırlı Karşılaştırma

acar6783 · 14 Şubat 2019

Hayırlı akşamlar,
Aşağıdaki kodlar ile yaklaşık 20.000 satırlık veriyi diğer excel dosyasındaki verilerle karşılaştırıp olmayanları listeliyorum. Aynı işlemi bir de ters taraftan yapacağım fakat sadece ilk taraf bile yaklaşık 3dk. sürüyor.
Aşağıdaki kodlara ek farklı önerileriniz bekler . Şimdiden teşekkür ederim.

Kod:

Sub kasa_rapor()
  scrfalse
With Sheets("HATALAR")
sat = 4

 dosya_yolu = ThisWorkbook.Path & "\108 EKSTRE.xls"
 dosya_yolu2 = ThisWorkbook.Path & "\108 MUAVİN.xls"
 
Set wb1 = Workbooks.Open(dosya_yolu)
Set wb11 = wb1.Sheets("EKSTRE")
Set wb2 = Workbooks.Open(dosya_yolu2)
Set wb22 = wb2.Sheets("MUAVİN")

.Range("A5:R" & Rows.Count).ClearContents
 

'If Left(wb11.Range("A1"), 15) <> Left(wb22.Range("A1"), 15) Then MsgBox "Raporlar Hatalı Tarih" & _
 Chr(13) & Left(wb11.Range("A1"), 15) & Chr(13) & Left(wb22.Range("A1"), 15), vbCritical + vbOKOnly, "Rapor Tarih Hatası": GoTo çıkış

For a = 4 To wb11.Cells(Rows.Count, "A").End(3).Row


If wb11.Cells(a, "A") <> "" And wb11.Cells(a, "D") <> "Devir" Then
aranan1 = wb11.Cells(a, "D")
aranan2 = wb11.Cells(a, "F")

If WorksheetFunction.CountIfs(wb22.Range("E2:E" & Rows.Count), aranan1, _
wb22.Range("G2:G" & Rows.Count), aranan2) = 0 Then

sat = sat + 1


.Cells(sat, "A") = wb11.Cells(a, "A")
.Cells(sat, "B") = wb11.Cells(a, "B")
.Cells(sat, "C") = wb11.Cells(a, "C")
.Cells(sat, "D") = wb11.Cells(a, "D")
.Cells(sat, "E") = wb11.Cells(a, "F")
.Cells(sat, "F") = wb11.Cells(a, "G")
.Cells(sat, "G") = wb11.Cells(a, "H")

End If
End If

Next a
çıkış:
 Workbooks("108 EKSTRE.xls").Close False
Workbooks("108 MUAVİN.xls").Close False
End With
 scrtrue
End Sub

Ömer BARAN · 14 Şubat 2019

Merhaba.
Sonuç alınabilecek veriler içerecek şekilde örnek belge takımı (HATALAR sayfasının olduğu sonuç belgesi, EKSTRE ve MUAVİN isimli belgeler) ekleyip,
koşulları ve alınacak verilere ilişkin kısa açıklama yazarak, mevcut makro ile alınmış sonuçları örneklendirirseniz daha hızlı sonuç alabileceğinizi düşünüyorum.
.

acar6783 · 15 Şubat 2019

https://yadi.sk/d/wCuETC5hnlBy9A

Dosyam ektedir. Öncelikle yukarıdaki kodlarda olduğu gibi ekstre sayfasının muavin safyasında olayanlarını bulup hatalar sayfasına getirmem gerekiyor.
Tabi daha hızlı bir yöntem olmalı

Ömer BARAN · 16 Şubat 2019

Merhaba.
Dosya ekte.
Aşağıdaki kod ve ekteki belge yenilendi: 16.02.2019 23:42

CSS:

Sub YENI()
Dim eks(), a(), b(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row
ReDim mv(1 To mson, 1 To 1)
For sat = 7 To mson
    ms = ms + 1
    mv(ms, 1) = wb2.Sheets("MUAVİN").Cells(sat, 5) & "|" & wb2.Sheets("MUAVİN").Cells(sat, 7)
Next
wb2.Close 0

    EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
    Set wb1 = Workbooks.Open(EY)
    eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
    ReDim eks(1 To eson, 1 To 1)
    For sat = 7 To eson
        es = es + 1
        eks(es, 1) = wb1.Sheets("EKSTRE").Cells(sat, 4) & "|" & wb1.Sheets("EKSTRE").Cells(sat, 6)
    Next sat
Set d = CreateObject("scripting.dictionary")
    a = mv
    For i = 1 To UBound(a): d(a(i, 1)) = d(a(i, 1)) + 1: Next i
    b = eks
    For i = 1 To UBound(b)
        If d.Exists(b(i, 1)) Or Cells(i + 6, 4) = "Devir" Then
            say = say + 1
            If say = 1 Then: Set adres = Cells(i + 6, 1)
            If say > 1 Then: Set adres = Union(adres, Cells(i + 6, 1))
        End If
    Next i
    If say > 0 Then
        wb1.Sheets("EKSTRE").Activate: adres.EntireRow.Delete Shift:=xlUp
    End If
    yapA = wb1.Sheets("EKSTRE").Range("A7:D" & wb1.Sheets("EKSTRE").Cells(Rows.Count, 1).End(3).Row).Value
    yapE = wb1.Sheets("EKSTRE").Range("F7:H" & wb1.Sheets("EKSTRE").Cells(Rows.Count, 1).End(3).Row).Value
    wb1.Close 0
    .[A6].Resize(UBound(yapA), 4) = yapA: .[E6].Resize(UBound(yapE), 3) = yapE
    .Columns("E:G").NumberFormat = "#,##0.00": Columns("A:A").NumberFormat = "mm/dd/yyyy"
End With
Erase a: Erase b:
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: sat = Empty: ms = Empty: eson = Empty: es = Empty: i = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
    "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End Sub

acar6783 · 16 Şubat 2019

Ömer bey elinize sağlık. Çok teşekkür ederim.
Kodları baştan sona belki 10defa okudum ama kurguyu anlayamadım.

Döngüyle tek karşılaştırma en az 2dk sürerken iki karşılaştırma 5-7saniyeye nasıl düştü anlayamadım. Ama gerçekten mükemmel olmuş. müsait olduğunuzda kodların kurgu mantığını anlatabilirseniz çok emnun kalırım.

Tekrar teşekkürler.

Ömer BARAN · 16 Şubat 2019

Cep telefonundan yazıyorum.
Kanaatim o ki; kodlar biraz daha kısalabilir.
Scripting dictionary satırına kadarki kısımda,
Ekstre ve muavin sayfalarındaki veriler, HATALAR sayfasında kendi sütunlarına olmak üzere alt alta ve H (yardımcı alan) sütununa da D ve E sütununun birleşimi yazılıyor.
Belirttiğim satırdan sonra da, ekstreden gelenler ile muavindan gelenler tek tek karşılaştırılıyor.
Ekstreden gelenlerden, muavinden gelenle aynı olanların satır numaraları değişkende biriktirilip, tek adımda bu satırlar ve muavinden gelen satırların tümü siliniyor.

Ömer BARAN · 16 Şubat 2019

Tekrar merhaba.

4 numaralı cevaptaki kodu ve ekindeki belgeyi yeniledim.
Belgede hem önceki verdiğim kod, hem de yeni verdiğim kod mevcuttur.
İşlem sonuçlarını ve sürelerini karşılaştırırsınız.
.

acar6783 · 17 Şubat 2019

Ömer bey tekrar çokteşekkür ederim.
Bu kadar satırı bu hızda hiçbir şekilde çözemezdim.
Aklıma takılna birkaç yer var;

Son kodlar sanırım sadece muavinden karşılatırma yapıyor. Diyeceğim fakat o zaman sonuç daha az cıkar. Kodları okurken kafam karıştı . Karşılaştırmayı nasıl yapıyor o

Kod:

Sub TEMIZLE()
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
End With
End Sub

Sub kasa_rapor_BARAN_YENI()
Dim eks(), a(), b(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
 
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\108 MUAVİN.xls").Sheets("MUAVİN")
mson = wb2.Cells(Rows.Count, "A").End(3).Row
ReDim mv(1 To mson, 1 To 1)
For sat = 7 To mson
    ms = ms + 1
    mv(ms, 1) = wb2.Cells(sat, 5) & "|" & wb2.Cells(sat, 7)
Next
Workbooks("108 MUAVİN.xls").Close 0

 
    Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\108 EKSTRE.xls").Sheets("EKSTRE")
    eson = wb1.Cells(Rows.Count, "A").End(3).Row
    ReDim eks(1 To eson, 1 To 1)
    For sat = 7 To eson
        es = es + 1
        eks(es, 1) = wb1.Cells(sat, 4) & "|" & wb1.Cells(sat, 6)
    Next sat
Set d = CreateObject("scripting.dictionary")
    a = mv 'burada neden mv dizisini a olarak değiştiriyouz?
    For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) + 1
    Next i
    'buradan sonra a dizisi ile ilgili bir yer göremedim kaşılaştırma nasıl oluyor olmadan?
    
    b = eks ' aynı şekilde burada da eks "b" olarak değiştirilmiş.
    For i = 1 To UBound(b)
   'If d.Exists(b(i, 1)) Kodun tam açılımı nedir? NEyi sorguluyouz?
  
        If d.Exists(b(i, 1)) Or Cells(i + 6, 4) = "Devir" Then
            say = say + 1
            If say = 1 Then: Set adres = Cells(i + 6, 1) 'Burada sadece cells kullanılmış?
            If say > 1 Then: Set adres = Union(adres, Cells(i + 6, 1)) 'union fonksiyonu tekrar tüm sonucları diziye mi yüklüyor?
        End If
    Next i
    If say > 0 Then
        wb1.Activate: adres.EntireRow.Delete Shift:=xlUp
    End If
    yapA = wb1.Range("A7:D" & wb1.Cells(Rows.Count, 1).End(3).Row).Value
    yapE = wb1.Range("F7:H" & wb1.Cells(Rows.Count, 1).End(3).Row).Value
 Workbooks("108 EKSTRE.xls").Close 0
    .[A6].Resize(UBound(yapA), 4) = yapA: .[E6].Resize(UBound(yapE), 3) = yapE
    .Columns("E:G").NumberFormat = "#,##0.00": Columns("A:A").NumberFormat = "mm/dd/yyyy"
End With
Erase a: Erase b:
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: sat = Empty: ms = Empty: eson = Empty: es = Empty: i = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
    "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End Sub


Sub kasa_rapor_BARAN()
Dim eks1(): Dim eks2(): Dim mua1(): Dim mua2(): Dim mua3(): Dim bir1(): Dim sonuc()
Dim a(), b(), c(), d As Object
Dim i As Long, say As Long

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).ClearContents
zaman = Timer
.Columns("H:H").Insert Shift:=xlToRight
    dosya_yolu = ThisWorkbook.Path & "\108 EKSTRE.xls"
    Set wb1 = Workbooks.Open(dosya_yolu)
    eks1 = wb1.Range("A7:D" & wb1.Cells(Rows.Count, "A").End(3).Row).Value
    eks2 = wb1.Range("F7:H" & wb1.Cells(Rows.Count, "A").End(3).Row).Value
    wb1.Close 0
son = .Cells(Rows.Count, 1).End(3).Row + 1
.Cells(son, 1).Resize(UBound(eks1), 4) = eks1
.Cells(son, 5).Resize(UBound(eks2), 3) = eks2

    dosya_yolu2 = ThisWorkbook.Path & "\108 MUAVİN.xls"
    Set wb2 = Workbooks.Open(dosya_yolu2)
    mua1 = wb2.Range("A7:B" & wb2.Cells(Rows.Count, "A").End(3).Row).Value
    mua2 = wb2.Range("E7:E" & wb2.Cells(Rows.Count, "A").End(3).Row).Value
    mua3 = wb2.Range("G7:I" & wb2.Cells(Rows.Count, "A").End(3).Row).Value
    wb2.Close 0
son = .Cells(Rows.Count, 1).End(3).Row + 1
.Cells(son, 1).Resize(UBound(mua1), 2) = mua1
.Cells(son, 4).Resize(UBound(mua2), 1) = mua2
.Cells(son, 5).Resize(UBound(mua3), 3) = mua3

birl = .Range("D6:E" & .Cells(Rows.Count, "A").End(3).Row).Value

ReDim sonuc(1 To UBound(birl), 1 To 1)
For sat = 1 To UBound(birl)
        satd = satd + 1
        sonuc(satd, 1) = birl(sat, 1) & "|" & birl(sat, 2)
Next
If satd > 0 Then .[H6].Resize(satd, 1) = sonuc
ilk = UBound(eks1) + 5
arason = ilk + UBound(mua1)
Erase eks1: Erase eks2: Erase mua1: Erase mua2: Erase mua3: Erase sonuc: Erase birl


Set d = CreateObject("scripting.dictionary")
    a = Range("H" & ilk + 1 & ":H" & arason).Value
    For i = 1 To UBound(a): d(a(i, 1)) = d(a(i, 1)) + 1: Next i
    
    b = Range("H6:H" & ilk).Value
    For i = 1 To UBound(b)
        If d.Exists(b(i, 1)) Or Cells(i + 5, 4) = "Devir" Then
            say = say + 1
            If say = 1 Then: Set adres = Cells(i + 5, 1)
            If say > 1 Then: Set adres = Union(adres, Cells(i + 5, 1))
        End If
    Next i
    If say > 0 Then
        Range("H" & ilk + 1 & ":H" & arason).EntireRow.Delete Shift:=xlUp
        adres.EntireRow.Delete Shift:=xlUp
    End If
.Columns("H:H").Delete Shift:=xlToLeft
.Columns("E:G").NumberFormat = "#,##0.00": Columns("A:A").NumberFormat = "mm/dd/yyyy"
End With
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
i = Empty: say = Empty: dosya_yolu = Empty: dosya_yolu2 = Empty: son = Empty
sat = Empty: satd = Empty: ilk = Empty: arason = Empty
MsgBox "TAMAM" & vbLf & "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End Sub

nu anlayamadım. Bir iki düzeltme yaptım tanımlama ile ilgili. Bikaç tane de sorum olacak bu konuda da yardımcı olabilirseniz sevinirim.

Ömer BARAN · 17 Şubat 2019

Tekrar merhaba.
Birbirinden ayrı olarak değerlendirilmesi için biraz uzatmıştım mevzuyu.
YENİ kod aşağıdaki gibi de düzenlenebilir, gereksiz tekrarlanmaları ayıkladım.

Rich (BB code):

Sub kasa_rapor_BARAN_YENI()
Dim eks(), a(), b(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row

Set d = CreateObject("scripting.dictionary")
ReDim mv(1 To mson, 1 To 1)
For sat = 7 To mson
    ms = ms + 1
    mv(ms, 1) = wb2.Sheets("MUAVİN").Cells(sat, 5) & "|" & wb2.Sheets("MUAVİN").Cells(sat, 7)
    d(mv(sat - 6, 1)) = d(mv(sat - 6, 1)) + 1
Next
wb2.Close 0

EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
Set wb1 = Workbooks.Open(EY)
eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
ReDim eks(1 To eson, 1 To 1)
For sat = 7 To eson
    es = es + 1
    eks(es, 1) = wb1.Sheets("EKSTRE").Cells(sat, 4) & "|" & wb1.Sheets("EKSTRE").Cells(sat, 6)
        If d.Exists(eks(sat - 6, 1)) Or Cells(sat, 4) = "Devir" Then
            say = say + 1
            If say = 1 Then: Set adres = Cells(sat, 1)
            If say > 1 Then: Set adres = Union(adres, Cells(sat, 1))
        End If
Next sat
   
If say > 0 Then
    wb1.Sheets("EKSTRE").Activate: adres.EntireRow.Delete Shift:=xlUp
    yapA = wb1.Sheets("EKSTRE").Range("A7:D" & eson - say).Value
    yapE = wb1.Sheets("EKSTRE").Range("F7:H" & eson - say).Value
        .[A6].Resize(UBound(yapA), 4) = yapA: .[E6].Resize(UBound(yapE), 3) = yapE
        .Columns("E:G").NumberFormat = "#,##0.00": Columns("A:A").NumberFormat = "mm/dd/yyyy"
End If
wb1.Close 0

End With
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: sat = Empty: ms = Empty: eson = Empty: es = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
    "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End Sub

Ziynettin · 17 Şubat 2019

Merhaba,

Tebrikler Ömer Bey, güzel çalışma olmuş.

Benden de çeşitlilik olsun. Sizin kodlar üzerinden.

Kod:

Sub YENI()
Dim a(), b(), c(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row
a = wb2.Sheets("MUAVİN").Range("A7:I" & mson).Value
wb2.Close 0


EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
Set wb1 = Workbooks.Open(EY)
eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
b = wb1.Sheets("EKSTRE").Range("A6:H" & eson).Value
wb1.Close 0


    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 5) = "Devir" Then
            krt = a(i, 5) & "|" & a(i, 7)
            d(krt) = d(krt) + 1
        End If
    Next i

    ReDim c(1 To UBound(b), 1 To 8)
    For i = 1 To UBound(b)
        krt = b(i, 4) & "|" & b(i, 6)
        If d(krt) = 0 Then
            say = say + 1
            For j = 1 To 8
                c(say, j) = b(i, j)
            Next j
        End If
    Next i
   
If say > 0 Then
    .[A6].Resize(say - 1).NumberFormat = "dd.mm.yyyy"
    .[F6].Resize(say - 1, 3).NumberFormat = "#,##0.00"
    .[A5].Resize(say, 8) = c
End If

Erase a: Erase b: Erase c
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: eson = Empty: i = Empty: j = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
"İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End With
End Sub

Ömer BARAN · 17 Şubat 2019

Eyvallah, Sayın Ziynettin.
Daha evvel de belirtmiştim, "zorla öğreteceksiniz dizi ve scripting.dictionary olayını" diye.
Bu tür konuya rastladığımda olabilir deyip ilgileniyorum, deneme/yanılma ile de olsa sonuca ulaşıyorum artık.

Yalnız verdiğiniz kod'da DEVİR kelimesine ilişkin istisna unutulmuş sanırım ve E,F,G'ye yazılacak veri F,G,H'ye yazılıyor durumda.
.

Ziynettin · 17 Şubat 2019

Yalnız verdiğiniz kod'da DEVİR kelimesine ilişkin istisna unutulmuş sanırım ve E,F,G'ye yazılacak veri F,G,H'ye yazılıyor durumda.
.

Kod:

Sub YENİ()
Dim a(), b(), c(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row
a = wb2.Sheets("MUAVİN").Range("A7:I" & mson).Value
wb2.Close 0


EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
Set wb1 = Workbooks.Open(EY)
eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
b = wb1.Sheets("EKSTRE").Range("A6:H" & eson).Value
wb1.Close 0


    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 5) <> "Devir" Then
            krt = a(i, 5) & "|" & a(i, 7)
            d(krt) = d(krt) + 1
        End If
    Next i

    ReDim c(1 To UBound(b), 1 To 7)
    For i = 1 To UBound(b)
    
    If b(i, 4) <> "Devir" Then
        krt = b(i, 4) & "|" & b(i, 6)
        If d(krt) = 0 Then
            say = say + 1
            c(say, 1) = b(i, 1)
            c(say, 2) = b(i, 2)
            c(say, 3) = b(i, 3)
            c(say, 4) = b(i, 4)
            c(say, 5) = b(i, 6)
            c(say, 6) = b(i, 7)
            c(say, 7) = b(i, 8)
        End If
        End If
    Next i
   
If say > 0 Then
    .[A6].Resize(say - 1).NumberFormat = "dd.mm.yyyy"
    .[E6].Resize(say - 1, 3).NumberFormat = "#,##0.00"
    .[A5].Resize(say, 7) = c
End If

Erase a: Erase b: Erase c
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: eson = Empty: i = Empty: j = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
"İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End With
End Sub

acar6783 · 17 Şubat 2019

Tekrar teşekkür ederim arkadaşlar. Dediğiniz gibi dizi ve scripting.dictionary olayının çok önemli olduğunu burada anlamış oldum.
Bunun üzerine daha çok çalışacağım.

Ömer BARAN · 19 Şubat 2019

Merhaba Sayın @Ziynettin .

Bir hususta fikrinizi almak istedim.

Gerek sizin verdiğiniz ve gerekse de benim verdiğim kod işlemi, 1-2 saniye aralığında tamamlıyor.
Ancak, merak ettiğim şudur; benim verdiğim her iki kod da sizin verdiğinize nazaran + % 40 gibi fazla zaman alıyor.
Örneğin sizin verdiğiniz kod işlemi 1,2 saniyede tamamlıyorsa, benim verdiğim kodlar 1,7 saniyede tamamlıyor gibi.
Hız farkının nedeni konusunda fikrinizi merak ediyorum.
.

acar6783 · 19 Şubat 2019

Ziynettin' Alıntı:

Merhaba,

Tebrikler Ömer Bey, güzel çalışma olmuş.

Benden de çeşitlilik olsun. Sizin kodlar üzerinden.

Kod:

Sub YENI()
Dim a(), b(), c(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row
a = wb2.Sheets("MUAVİN").Range("A7:I" & mson).Value
wb2.Close 0


EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
Set wb1 = Workbooks.Open(EY)
eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
b = wb1.Sheets("EKSTRE").Range("A6:H" & eson).Value
wb1.Close 0


    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 5) = "Devir" Then
            krt = a(i, 5) & "|" & a(i, 7)
            d(krt) = d(krt) + 1
        End If
    Next i

    ReDim c(1 To UBound(b), 1 To 8)
    For i = 1 To UBound(b)
        krt = b(i, 4) & "|" & b(i, 6)
        If d(krt) = 0 Then
            say = say + 1
            For j = 1 To 8
                c(say, j) = b(i, j)
            Next j
        End If
    Next i
  
If say > 0 Then
    .[A6].Resize(say - 1).NumberFormat = "dd.mm.yyyy"
    .[F6].Resize(say - 1, 3).NumberFormat = "#,##0.00"
    .[A5].Resize(say, 8) = c
End If

Erase a: Erase b: Erase c
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: eson = Empty: i = Empty: j = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
"İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End With
End Sub

Bu kodları çalıştırdığımda rapor hatalı gelmiş oluyor. tespit edilen farklar. iki kayıtta da mevcut.

acar6783 · 19 Şubat 2019

Ömer BARAN' Alıntı:

Tekrar merhaba.
Birbirinden ayrı olarak değerlendirilmesi için biraz uzatmıştım mevzuyu.
YENİ kod aşağıdaki gibi de düzenlenebilir, gereksiz tekrarlanmaları ayıkladım.

Rich (BB code):

Sub kasa_rapor_BARAN_YENI()
Dim eks(), a(), b(), d As Object
Dim i As Long, say As Long
With Sheets("HATALAR")
If .Cells(Rows.Count, 1).End(3).Row > 5 Then .Range("A6:G" & .Cells(Rows.Count, 1).End(3).Row).Clear
zaman = Timer

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.DisplayAlerts = False

MY = ThisWorkbook.Path & "\108 MUAVİN.xls"
Set wb2 = Workbooks.Open(MY)
mson = wb2.Sheets("MUAVİN").Cells(Rows.Count, "A").End(3).Row

Set d = CreateObject("scripting.dictionary")
ReDim mv(1 To mson, 1 To 1)
For sat = 7 To mson
    ms = ms + 1
    mv(ms, 1) = wb2.Sheets("MUAVİN").Cells(sat, 5) & "|" & wb2.Sheets("MUAVİN").Cells(sat, 7)
    d(mv(sat - 6, 1)) = d(mv(sat - 6, 1)) + 1
Next
wb2.Close 0

EY = ThisWorkbook.Path & "\108 EKSTRE.xls"
Set wb1 = Workbooks.Open(EY)
eson = wb1.Sheets("EKSTRE").Cells(Rows.Count, "A").End(3).Row
ReDim eks(1 To eson, 1 To 1)
For sat = 7 To eson
    es = es + 1
    eks(es, 1) = wb1.Sheets("EKSTRE").Cells(sat, 4) & "|" & wb1.Sheets("EKSTRE").Cells(sat, 6)
        If d.Exists(eks(sat - 6, 1)) Or Cells(sat, 4) = "Devir" Then
            say = say + 1
            If say = 1 Then: Set adres = Cells(sat, 1)
            If say > 1 Then: Set adres = Union(adres, Cells(sat, 1))
        End If
Next sat
  
If say > 0 Then
    wb1.Sheets("EKSTRE").Activate: adres.EntireRow.Delete Shift:=xlUp
    yapA = wb1.Sheets("EKSTRE").Range("A7:D" & eson - say).Value
    yapE = wb1.Sheets("EKSTRE").Range("F7:H" & eson - say).Value
        .[A6].Resize(UBound(yapA), 4) = yapA: .[E6].Resize(UBound(yapE), 3) = yapE
        .Columns("E:G").NumberFormat = "#,##0.00": Columns("A:A").NumberFormat = "mm/dd/yyyy"
End If
wb1.Close 0

End With
Set d = Nothing: MY = Empty: EY = Empty: Set wb1 = Nothing: Set wb2 = Nothing
say = Empty: mson = Empty: sat = Empty: ms = Empty: eson = Empty: es = Empty
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
MsgBox "Listeleme tamamlandı." & vbLf & _
    "İşlem süresi: " & Format(Timer - zaman, "0.00") & " saniye", vbInformation, "..:: Ömer BARAN ::.."
zaman = Empty
End Sub

Ömer bey sizden rica redim ve script.dic olayları hakkında detaylı bir çalışma olduğu için müsait bir anınızda kodların altına açıklama yapabilirmisiniz?

acar6783 · 19 Şubat 2019

Ek olarak bir de kodları tam algılayamadığım için bir sorum daha olacak;
karşılaştırma bittiğinde hangi satırın hangi dosyaya ait olduğunu Ek bir sütuna getirtebilirmiyiz ?

Ziynettin · 19 Şubat 2019

acar6783' Alıntı:
Bu kodları çalıştırdığımda rapor hatalı gelmiş oluyor. tespit edilen farklar. iki kayıtta da mevcut.

Konuyu eksik anlamışım.
#12. iletideki kodu deneyiniz.

acar6783 · 19 Şubat 2019

Ziynettin' Alıntı:
Konuyu eksik anlamışım.
#12. iletideki kodu deneyiniz.

Tespit edilen farklarda görünen;
İŞ BANKASI MERKEZ MAĞAZA VİSA HESABI-MÜŞ.K.KRT.NA İADE (014706) İŞ BAN 168 nolu
kayıt aslında iki tarafta da olmasına rağmen geliyor. Sebebi; "nolu" yazan bölüm bir tarfa "nolu" diğer tarafta "nolu " olarak yazılmış.
Buradaki sorun aslında hatayı doğru tespit etmesine rağmen neden bir kayıt olarak getiriyor olabilir?
İki kaydı da getirmesi gerekir sonuçta ikisi de karşılıklı olarak eşleşmiyor.

Ziynettin · 19 Şubat 2019

Boşluk karakter sorunu olabilir.

krt = a(i, 5) & "|" & a(i, 7) satırını krt = Application.Trim(a(i, 5)) & "|" & a(i, 7)

krt = b(i, 4) & "|" & b(i, 6) satırını krt = Application.Trim(b(i, 4)) & "|" & b(i, 6)

şeklinde deneyiniz.

Çok satırlı Karşılaştırma

acar6783

Ömer BARAN

Uzman

acar6783

Ömer BARAN

Uzman

Ekli dosyalar

acar6783

Ömer BARAN

Uzman

Ömer BARAN

Uzman

acar6783

Ömer BARAN

Uzman

Ziynettin

Destek Ekibi

Ömer BARAN

Uzman

Ziynettin

Destek Ekibi

acar6783

Ömer BARAN

Uzman

acar6783

acar6783

acar6783

Ziynettin

Destek Ekibi

acar6783

Ziynettin

Destek Ekibi