Skip to main content

AccessTr.neT M.


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

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

#7
(02/03/2020 21:02)accessman Adlı Kullanıcıdan Alıntı: 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.

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

Kestirme yoldan yaptım.

Cevapla
...........
#9
Son Düzenleme: 02/03/2020, 22:35, Düzenleyen: feraz.
Alttaki kodda açıklamalar ekledim ve daha hızlı çalışır.

Visual Basic Code
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

Cevapla
#10
Son Düzenleme: 03/03/2020, 15:51, Düzenleyen: HORZUM.
FERAZ ve BERDUŞ çok teşekkürler ellerinize sağlık. Size kolay gelsin

Cevapla
...........
#11
Rica ederiz.

Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da