DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub AraBulGetir()
Dim i As Long, j As Long, Son As Long
Dim Bul As Range
Dim IlkAdres As String
Dim sk As Worksheet, sr As Worksheet
Set sk = Sheets("KAYIT")
Set sr = Sheets("RAPOR")
sr.Select
Son = sk.[A65536].End(3).Row
j = 1
Application.ScreenUpdating = False
Range("C2:D65536").ClearContents
For i = 2 To [A65536].End(3).Row
With sk.Range("a1:a" & Son)
Set Bul = .Find(Cells(i, "A"), LookIn:=xlValues)
If Not Bul Is Nothing Then
IlkAdres = Bul.Address
Do
j = j + 1
Cells(j, "C") = Bul.Address
Cells(j, "D") = sk.Cells(Bul.Row, "A")
Set Bul = .FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> IlkAdres
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Sub aktar()
Dim s1 As Worksheet, sat As Long, i As Long, deg1 As String
Dim deg2 As String, deg3 As String
Dim kdeg As String
Sheets("RAPOR").Select
deg1 = UCase(Replace(Replace(Range("A1").Value, "ı", "I"), "i", "İ"))
deg2 = UCase(Replace(Replace(Range("A2").Value, "ı", "I"), "i", "İ"))
deg3 = UCase(Replace(Replace(Range("A3").Value, "ı", "I"), "i", "İ"))
sat = 5
Set s1 = Sheets("KAYIT")
Application.ScreenUpdating = False
Range("A5:B65536").ClearContents
For i = 1 To s1.Cells(65536, "A").End(xlUp).Row
kdeg = UCase(Replace(Replace(s1.Cells(i, "A").Value, "ı", "I"), "i", "İ"))
'If VERİ Like "*" & KRİTER & "*" Then HÜCRE.Interior.ColorIndex = 6
If kdeg Like "*" & deg1 & "*" Or kdeg Like "*" & deg2 & "*" Or kdeg Like "*" & deg3 & "*" Then
Cells(sat, "A").Value = "A" & i
Cells(sat, "B").Value = kdeg
sat = sat + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"
End Sub
