Option Compare Text
Sub Bul()
Dim son As Long, i As Long, say As Long, arr
Dim sVeri As Worksheet: Set sVeri = Sheets("Veri")
Dim sKategoriListesi As Worksheet: Set sKategoriListesi = Sheets("KategoriListesi")
Dim sSonuc As Worksheet: Set sSonuc = Sheets("Sonuc")
With sVeri
son = .Cells(Rows.Count, "F").End(3).Row
ReDim arr(1 To son, 1 To 2)
say = 0
With sSonuc
.Range("A2:B" & Rows.Count).ClearContents
.Range("A1").Value = "NO"
.Range("B1").Value = "SONUCLAR"
End With
On Error Resume Next
For i = 12 To son
If WorksheetFunction.Match(.Cells(i, "F").Value, sKategoriListesi.Range("L:L"), 0) = 0 Then
say = say + 1
arr(say, 1) = say
arr(say, 2) = .Cells(i, "F").Value
End If
Next
sSonuc.Range("A2").Resize(say, 2).Value = arr
Application.ScreenUpdating = True
End With
MsgBox "Bitti", vbInformation, "Bilgi"
On Error Resume Next
Erase arr
Set sVeri = Nothing
Set sKategoriListesi = Nothing
Set sSonuc = Nothing
End Sub
Deneme - Kısa2.rar
(Dosya Boyutu: 28,67 KB | İndirme Sayısı: 4)
