DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Aktar()
Dim a, i, s As Long, b()
Set s1 = Sheets("Personel")
Set s2 = Sheets("Veri")
a = s1.Range("a2:a" & s1.[a65536].End(xlUp).Row).Resize(, 6).Value
ReDim b(1 To UBound(a, 1), 1 To 6)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
s = s + 1
.Add (a(i, 2)), s
b(s, 1) = s
b(s, 2) = a(i, 2)
b(s, 3) = a(i, 3)
b(s, 4) = a(i, 4)
b(s, 5) = a(i, 5)
b(s, 6) = a(i, 6)
End If
Next
End With
With s2.Range("a2")
.Resize(, 6).ClearContents
.Resize(s, 6).Value = b
End With
MsgBox "Bitti"
s2.Select
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub
Public Sub Getir()
Application.ScreenUpdating = False
Set p = Sheets("Personel")
Range("A2:F65536").ClearContents
Satır = 1
For i = 2 To p.[B65536].End(3).Row
Satır = Satır + 1
Cells(Satır, "A") = p.Cells(i, "A")
Cells(Satır, "B") = p.Cells(i, "B")
Cells(Satır, "C") = p.Cells(i, "C")
Cells(Satır, "D") = p.Cells(i, "D")
Cells(Satır, "E") = p.Cells(i, "E")
Cells(Satır, "F") = p.Cells(i, "F")
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Bitmiştir........"
End Sub