DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Fast_Vlookup()
Dim S1 As Worksheet, Son As Long, Zaman As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Zaman = Timer
Set S1 = ActiveSheet
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
S1.Range("F2:J" & S1.Rows.Count).ClearContents
With S1.Range("F2:J" & Son)
.Formula = "=VLOOKUP(A2,'" & S1.Name & "'!$K:$K,1,0)"
.Value = .Value
End With
Set S1 = Nothing
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Sub test_1()
Dim S1 As Worksheet, s2 As Worksheet
Dim dic As Object, i As Long
Dim a(), b(), c()
t = TimeValue(Now)
Set S1 = Sheets("Data")
Set s2 = Sheets("LOOKUP")
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
a = S1.Range("A2:E" & S1.Cells(Rows.Count, 1).End(3).Row).Value
b = s2.Range("A2:A" & s2.Cells(Rows.Count, 1).End(3).Row).Value
For i = 1 To UBound(b)
dic(b(i, 1)) = b(i, 1)
Next i
ReDim c(1 To UBound(b), 1 To 4)
For i = 1 To UBound(a)
If dic.exists(a(i, 1)) Then
dic1(a(i, 1)) = i
End If
Next i
For i = 1 To UBound(b)
For j = 1 To 4
c(i, j) = a(dic1(b(i, 1)), j + 1)
Next j
Next i
s2.Range("K2:N" & s2.Cells(Rows.Count, "K").End(3).Row) = ""
s2.[K2].Resize(UBound(b), 4) = c
MsgBox CDate(TimeValue(Now) - t), vbInformation
End Sub