DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub AKTAR()
Dim S1 As Worksheet, S2 As Worksheet
Dim Veri As Range, Son As Long, Bul As Range
Set S1 = Sheets("Tablo1")
Set S2 = Sheets("Tablo2")
S2.Range("L:L").ClearContents
Son = S2.Cells(S2.Rows.Count, "N").End(3).Row
For Each Veri In S2.Range("N2:N" & Son)
For X = 15 To 25
Set Bul = S1.Cells.Find(S2.Cells(Veri.Row, X), , , xlWhole)
If Not Bul Is Nothing Then
S2.Cells(Veri.Row, "L") = S1.Cells(Bul.Row, "M")
Exit For
End If
Next
Next
Set Bul = Nothing
Set S1 = Nothing
Set S2 = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End SubOption Explicit
Sub aktar()
Dim a(), b(), c(), d As Object, deg As Variant
Dim i As Long, Y As Integer, Son1 As Long, Son2 As Long
Dim S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("Tablo1")
Set S2 = Sheets("Tablo2")
Set d = CreateObject("Scripting.Dictionary")
Son1 = S1.Cells(Rows.Count, "B").End(3).Row
a = S1.Range("B2:M" & Son1).Value
For i = 1 To UBound(a)
deg = ""
For Y = 1 To UBound(a, 2) - 1: deg = deg & a(i, Y): Next Y
d(deg) = a(i, UBound(a, 2))
Next i
Son2 = S2.Cells(Rows.Count, "N").End(3).Row
b = S2.Range("O2:Y" & Son2).Value
ReDim c(1 To UBound(b), 1 To 1)
For i = 1 To UBound(b)
deg = ""
For Y = 1 To UBound(b, 2): deg = deg & b(i, Y): Next Y
c(i, 1) = d(deg)
Next i
S2.Range("L2:L" & Rows.Count).ClearContents
S2.Range("L2").Resize(UBound(b)) = c
MsgBox "İşlem tamam....", vbInformation
End Sub