Çözüldü Makro Düzenlenmesi

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
62
En iyi yanıt
0
Puanları
18
Yaş
33
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Office Versiyon
Office 2016 Pro
Merhaba;

200.000 üzeri satır ile işlem yapılmaktadır. makronun hızlı çalışabilmesi için nasıl bir düzenleme yapılabilir. Yardımcı olabilir misiniz. Teşekkürler.

Kod:
Sub bul()
Dim son1 As Long: son1 = Sheet1.Cells(Rows.Count, "A").End(3).Row
Dim son2 As Long: son2 = Sheet1.Cells(Rows.Count, "M").End(3).Row
Dim son3 As Long: son3 = Sheet2.Cells(Rows.Count, "E").End(3).Row + 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Sheet2.Range("E2:G" & son3).ClearContents

For i = 2 To son1
son3 = Sheet2.Cells(Rows.Count, "E").End(3).Row + 1
If say(Sheet1.Range("N2:N" & son2), Sheet1.Cells(i, "B")) = 0 Then
Sheet2.Cells(son3, "E") = Sheet1.Cells(i, "A").Value
Sheet2.Cells(son3, "F") = Sheet1.Cells(i, "B").Value
Sheet2.Cells(son3, "G") = "2.ci Listede Yok"

End If
Next
For i = 2 To son2
son3 = Sheet2.Cells(Rows.Count, "E").End(3).Row + 1
If say(Sheet1.Range("B2:B" & son1), Sheet1.Cells(i, "N")) = 0 Then
Sheet2.Cells(son3, "E") = Sheet1.Cells(i, "M").Value
Sheet2.Cells(son3, "F") = Sheet1.Cells(i, "N").Value
Sheet2.Cells(son3, "G") = "1.ci Listede Yok"

End If
Next
son3 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1
    Sheet2.Range("A2:D" & son3).ClearContents
For i = 2 To son1
son3 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1
If say(Sheet1.Range("N2:N" & son2), Sheet1.Cells(i, "B")) <> 0 Then
Sheet2.Cells(son3, "A") = Sheet1.Cells(i, "A").Value
Sheet2.Cells(son3, "B") = Sheet1.Cells(i, "B").Value
Sheet2.Cells(son3, "C") = Sheet1.Cells(i, "U").Value - Sheet1.Cells(i, "I").Value
Sheet2.Cells(son3, "D") = Sheet1.Cells(i, "K").Value

End If
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False

End Sub
Function say(ByVal userRange As Variant, ByVal userCriteria As Variant)
    say = Application.WorksheetFunction.CountIf(userRange, userCriteria)
End Function
 

Murat OSMA

Yönetici
Site Yöneticisi
Katılım
25 May 2018
Mesajlar
1,309
En iyi yanıt
10
Puanları
113
Konum
İstanbul
Web sitesi
excelarsivi.com
Ad Soyad
Murat OSMA
Office Versiyon
Office 365 TR+EN
Merhaba,

Aynı döngüyü birkaç kez kurmak pek mantıklı değil, tek döngüde halledilebilir, onun haricinde alternatif çözümler de sunulabilir fakat örnek dosyanızı ve ne yapmak istediğinizi belirtmeniz daha sağlıklı olacaktır.
 

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
62
En iyi yanıt
0
Puanları
18
Yaş
33
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Office Versiyon
Office 2016 Pro
Merhaba,

Aynı döngüyü birkaç kez kurmak pek mantıklı değil, tek döngüde halledilebilir, onun haricinde alternatif çözümler de sunulabilir fakat örnek dosyanızı ve ne yapmak istediğinizi belirtmeniz daha sağlıklı olacaktır.
Merhaba;
Konu hakkında örnek ektedir. Sonuç Sayfasında detay açıklanmıştır.
 

Ekli dosyalar

  • Örnek.xlsx
    16.5 KB · Görüntüleme: 13

Murat OSMA

Yönetici
Site Yöneticisi
Katılım
25 May 2018
Mesajlar
1,309
En iyi yanıt
10
Puanları
113
Konum
İstanbul
Web sitesi
excelarsivi.com
Ad Soyad
Murat OSMA
Office Versiyon
Office 365 TR+EN
Merhaba Sn. @gicimi,

ADO ile çok daha hızlı bir şekilde raporlayabilirsiniz.
Bu kodlar işinizi görecektir.
PHP:
DefObj C, R: DefStr S
Sub Emre()
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=yes"""
    Application.ScreenUpdating = False
    Sayfa3.Range("A2:D500000").Delete Shift:=xlUp
    sorgu = "SELECT [Tipi1],[Malzeme No1], s2.[Per2],(s2.[Gerçek tarihi2]-[s1.Gerçek tarihi1]) FROM"
    sorgu = sorgu & " [Sayfa1$] as s1 LEFT JOIN [Sayfa2$] as s2 ON s1.[Malzeme No1]=s2.[Malzeme No2]"
    rs.Open sorgu, con, 1, 1
    Sayfa3.Range("A2").End(3)(2, 1).CopyFromRecordset rs
    rs.Close
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı.", vbInformation, "Www.ExcelTurkey.Com"
    Set con = Nothing: Set rs = Nothing: sorgu = vbNullString
End Sub
Ek'teki dosyayı indirip kullanabilirsiniz.
Analiz sayfası için istediğinizi de bu örnek kodlara bakarak siz de yazabilirsiniz diye düşünüyorum.

Saygılar
 

Ekli dosyalar

  • Ado ile Iki Tabloyu Karşılaştırıp Raporlama.rar
    22.4 KB · Görüntüleme: 16

gicimi

Yeni Üye
Katılım
18 Haz 2018
Mesajlar
62
En iyi yanıt
0
Puanları
18
Yaş
33
Konum
Ankara
Ad Soyad
Hüseyin Yılmaz
Office Versiyon
Office 2016 Pro
Merhaba;

Çok teşekkür ederim. Emeğinize sağlık.
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst Alt