Buton Yardımı İle Sheet1 Deki Bilgileri Sheet2'ye Alt Alta Sıralı Olarak Kopyalama

(02/03/2020, 21:02)accessman yazdı: Application.ScreenUpdating = True
Bu satır ne işe yarıyor 

Ekran tazelemesi heralde türkçesi.
Yani echo.true gibi accesin.

False olursa ekran tazelemeyi kapatır true ise normale çevirir.

Aslında dizi içine alınıp dictionary ilede kıyaslamada yaptırılabilinir hız için.

Kestirme yoldan yaptım.

Alttaki kodda açıklamalar ekledim ve daha hızlı çalışır.

Option Compare Text 'Kücük büyük ayrimi yaptirmamak icin



Sub Makro2()





    Dim sayfaveri

    Dim i As Long, kriter1 As String, kriter2 As String

    Dim son As Long, j As Byte

    Dim arr, scr As Object, arr2

    Dim MUVAFAKAT As Worksheet

    Dim veri As Worksheet

    

    Set MUVAFAKAT = Worksheets("MUVAFAKAT")

    Set veri = Worksheets("VERÝ")

    

    arr = Array("K5", "K4", "K6", "A10", "A14", "Y18", "Y19", "A25", "C28", "G41", "G42", "G43", "U43", "U44", "U45") 'MUVAFAKAT sayfasi ilgili hücreler

    

    son = veri.Range("A" & Rows.Count).End(3).Row 'veri sayfasi son dolu satir no

    If son < 2 Then GoTo var 'Eger ilk dolu satir no kücüktür 2 ise Var: yazan yere git

    arr2 = veri.Range("A2:O" & son).Value 'veri sayfasin A2 ile O son dolu hücreleri dii icine alindi



    Application.ScreenUpdating = False 'Ekran tazeleme kapatir

    

    For j = LBound(arr) To UBound(arr) 'arr arrayinin icindekiler göngüye sokulur

        kriter2 = kriter2 & MUVAFAKAT.Range(arr(j)).Value & "|" 'MUVAFAKAT sayfasinin ilgili hücreleri birlestirilir yukardaki arr icindekilerle hücre degerleri bulunup

    Next

    

    kriter2 = Mid(kriter2, 1, Len(kriter2) - 1) 'sonucta en sonda | isaret ciktigi icin onu aldirmadik

    

    For i = LBound(arr2, 1) To UBound(arr2, 1) 'Dizinin satirlari arasinda dolasiyor

        For j = LBound(arr2, 2) To UBound(arr2, 2) 'Dizinin sütunlari arasinda dolasiyor

            kriter1 = kriter1 & arr2(i, j) & "|" 'burdada kriter2 deki olayin aynisi

        Next

        

        kriter1 = Mid(kriter1, 1, Len(kriter1) - 1) 'sonucta en sonda | isaret ciktigi icin onu aldirmadik

        If LCase(kriter1) = LCase(kriter2) Then GoTo son 'eger kiyaslama esit olursa islem iptal edilip mesaj verdirilir.

        kriter1 = vbNullString

    Next

    

var:



    say = veri.Range("A65530").End(3).Row + 1

    veri.Range("A" & say) = MUVAFAKAT.Range("K5")

    veri.Range("B" & say) = MUVAFAKAT.Range("K4")

    veri.Range("C" & say) = MUVAFAKAT.Range("K6")

    veri.Range("D" & say) = MUVAFAKAT.Range("A10")

    veri.Range("E" & say) = MUVAFAKAT.Range("A14")

    veri.Range("F" & say) = MUVAFAKAT.Range("Y18")

    veri.Range("G" & say) = MUVAFAKAT.Range("Y19")

    veri.Range("H" & say) = MUVAFAKAT.Range("A25")

    veri.Range("I" & say) = MUVAFAKAT.Range("C28")

    veri.Range("J" & say) = MUVAFAKAT.Range("G41")

    veri.Range("K" & say) = MUVAFAKAT.Range("G42")

    veri.Range("L" & say) = MUVAFAKAT.Range("G43")

    veri.Range("M" & say) = MUVAFAKAT.Range("U43")

    veri.Range("N" & say) = MUVAFAKAT.Range("U44")

    veri.Range("O" & say) = MUVAFAKAT.Range("U45")

    

    'Alttakilerlede temizlemeler yapilir dizzi vs...

    

    On Error Resume Next

    Erase arr: Erase arr2

    kriter1 = vbNullString

    kriter2 = vbNullString

    Set MUVAFAKAT = Nothing

    Set veri = Nothing

    

    Application.ScreenUpdating = True 'Ekran tazeleme acar

    Exit Sub



son:

    MsgBox "Mükerrer Kayit", vbCritical, "Mükerrer"



    Erase arr: Erase arr2

    kriter1 = vbNullString

    kriter2 = vbNullString

    Set MUVAFAKAT = Nothing

    Set veri = Nothing

Application.ScreenUpdating = True 'Ekran tazeleme acar



End Sub

FERAZ ve BERDUŞ çok teşekkürler ellerinize sağlık. Size kolay gelsin

Rica ederiz.