Bu Makro'da Sayfa 2 deki A Sütun Sayfa 1 deki A Sütun İle Karşılaşıyor Aynı İse A Sütunları B Sütun İçeriği Sayfa 2 ye Yazılıyor İstenilen Revizyon Sayfa2 A Sayfa1 Aynı İse Sayfa1 B, C, D, E, F, G hepsi Sayfa 2 ye Yazılısılsın Sayfa 2 A Sayfa 1 A da bulunmazsa Bulunamayan Sayfa 3 e yazilsin
Kod:
Sub Fast_Vlookup()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim Veri As Variant, X As Long
Dim Zaman As Double, Say1 As Long, Say2 As Long
Zaman = Timer
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set S3 = Sheets("Sayfa3")
Veri = S1.Range("A1").CurrentRegion.Value
With VBA.CreateObject("Scripting.Dictionary")
For X = LBound(Veri, 1) To UBound(Veri, 1)
.Item(Veri(X, 1)) = Veri(X, 2)
Next
Veri = S2.Range("A2:B" & S2.Cells(S2.Rows.Count, 1).End(3).Row).Value
ReDim Liste1(1 To S2.Rows.Count, 1 To 2)
ReDim Liste2(1 To S2.Rows.Count, 1 To 2)
For X = LBound(Veri, 1) To UBound(Veri, 1)
If .Exists(Veri(X, 1)) Then
Say1 = Say1 + 1
Liste1(Say1, 1) = Veri(X, 1)
Liste1(Say1, 2) = .Item(Veri(X, 1))
Else
Say2 = Say2 + 1
Liste2(Say2, 1) = Veri(X, 1)
Liste2(Say2, 2) = Veri(X, 2)
End If
Next
S2.Range("A2:B" & Rows.Count).ClearContents
S3.Range("A2:B" & Rows.Count).ClearContents
S2.Range("A2").Resize(Say1, 2).Value = Liste1
S3.Range("A2").Resize(Say2, 2).Value = Liste2
End With
Set S1 = Nothing: Set S2 = Nothing: Set S3 = Nothing
Erase Veri: Erase Liste1: Erase Liste2
MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
