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
