İnternetten araştırmalarım sonucu aşağıdaki kodu buldum ancak kendi dosyama nasıl uyarlayabilirim
Private Declare Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
Function MicroTimer() As Double
Dim cyTicks1 As Currency
Static cyFrequency As Currency
MicroTimer = 0
If cyFrequency = 0 Then getFrequency cyFrequency
getTickCount cyTicks1
If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function
Sub RangeTimer()
Dim ws As Worksheet
Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
lrd = ws.Cells(Rows.Count, "A").End(xlUp).Row
With ws
If ActiveCell.Column = 5 Then
.Range("F2:G" & lr).ClearContents
.Range("E2").FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],R1C1:R" & lrd & "C2,2,FALSE),""Bulunamadi"")"
.Range("E2").Copy
.Range("E2:E" & lr).PasteSpecial (xlPasteFormulas)
ElseIf ActiveCell.Column = 6 Then
.Range("E2:E" & lr).ClearContents
.Range("G2:G" & lr).ClearContents
.Range("F2").FormulaR1C1 = "=IF(RC[-2]=VLOOKUP(RC[-2],R1C1:R" & lrd & "C1,1,TRUE),VLOOKUP(RC[-2],R1C1:R" & lrd & "C2,2,TRUE),""Bulunamadi"")"
.Range("F2").Copy
.Range("F2:F" & lr).PasteSpecial (xlPasteFormulas)
ElseIf ActiveCell.Column = 7 Then
.Range("E2:G" & lr).ClearContents
.Range("G2:G" & lr).Select
End If
End With
ActiveCell.Activate
Application.CutCopyMode = False
DoCalcTimer 1
End Sub
Sub SheetTimer()
DoCalcTimer 2
End Sub
Sub RecalcTimer()
DoCalcTimer 3
End Sub
Sub FullcalcTimer()
DoCalcTimer 4
End Sub
Sub DoCalcTimer(jMethod As Long)
Dim dTime As Double
Dim dOvhd As Double
Dim oRng As Range
Dim oCell As Range
Dim oArrRange As Range
Dim sCalcType As String
Dim lCalcSave As Long
Dim bIterSave As Boolean
Dim ws As Worksheet
Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, "D").End(xlUp).Row
lrd = ws.Cells(Rows.Count, "A").End(xlUp).Row
On Error GoTo Errhandl
dTime = MicroTimer
lCalcSave = Application.Calculation
bIterSave = Application.Iteration
If Application.Calculation <> xlCalculationManual Then
Application.Calculation = xlCalculationManual
End If
Select Case jMethod
Case 1
dTime = MicroTimer
If Application.Iteration <> False Then
Application.Iteration = False
End If
If Selection.Count > 1000 Then
Set oRng = Intersect(Selection, Selection.Parent.UsedRange)
Else
Set oRng = Selection
End If
For Each oCell In oRng
If oCell.HasArray Then
If oArrRange Is Nothing Then
Set oArrRange = oCell.CurrentArray
End If
If Intersect(oCell, oArrRange) Is Nothing Then
Set oArrRange = oCell.CurrentArray
Set oRng = Union(oRng, oArrRange)
End If
End If
Next oCell
sCalcType = "Calculate " & CStr(oRng.Count) & _
" Cell(s) in Selected Range: "
Case 2
sCalcType = "Recalculate Sheet " & ActiveSheet.Name & ": "
Case 3
sCalcType = "Recalculate open workbooks: "
Case 4
sCalcType = "Full Calculate open workbooks: "
End Select
If ActiveCell.Column = 7 Then
Call TimerModule.DictionaryVLookup
Else
Select Case jMethod
Case 1
If Val(Application.Version) >= 12 Then
oRng.CalculateRowMajorOrder
Else
oRng.Calculate
End If
Case 2
ActiveSheet.Calculate
Case 3
Application.Calculate
Case 4
Application.CalculateFull
End Select
End If
dTime = MicroTimer - dTime
On Error GoTo 0
dTime = Round(dTime, 5)
MsgBox sCalcType & " " & CStr(dTime) & " Seconds" & vbNewLine & vbNewLine & "*Main Table Contains " & lrd - 1 & " Rows", _
vbOKOnly + vbInformation, "CalcTimer"
Finish:
If Application.Calculation <> lCalcSave Then
Application.Calculation = lCalcSave
End If
If Application.Iteration <> bIterSave Then
Application.Calculation = bIterSave
End If
Exit Sub
Errhandl:
On Error GoTo 0
MsgBox "Unable to Calculate " & sCalcType, _
vbOKOnly + vbCritical, "CalcTimer"
GoTo Finish
End Sub
Sub DictionaryVLookup()
Dim x, x2, y, y2()
Dim dict As Object
Dim ws As Worksheet
Set ws = ActiveSheet
Set dict = CreateObject("Scripting.Dictionary")
With ws
lr = .Cells(Rows.Count, "A").End(xlUp).Row
x = .Range("A2:A" & lr).Value
x2 = .Range("B2:B" & lr).Value
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x2(i, 1)
Next i
lr2 = .Cells(Rows.Count, "D").End(xlUp).Row
y = .Range("D2
" & lr2).Value
ReDim y2(1 To UBound(y, 1), 1 To 1)
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "Bulunamadi"
End If
Next i
.Range("G2:G" & lr2).Value = y2
.Range("G2:G" & lr2).Select
End With
Set dict = Nothing
End Sub
