hücre içinde tam eşleşen sonuca göre arama yapma

[unutkan518]

Merhabalar

Dosya şu şekilde
A sutunda bulunduğunda yazılacak kod
b sutununda arama yapılacak kod

d sutunu verilerin bulunduğu kod
e sutunu verilerin bulunduğu açıklama


E sutununda aşağıya doğru devam eden uzun bir liste var


A sut. ------------ b sut -------------- d sut ------------ e sut
kod-----------arama yap.kod-------veri kod----------veri açıklama

100 ----------AA-1000***************200----------DENEME BB-1200 DENEME
200---------- BB-1200***************100----------DENEME DENEME AA-1000 DENEME
300 ----------CC-1500***************500----------DENEME AA-900 DENEME
400----------AA-1500***************600----------DENEME AA-900K DENEME
500----------AA-900***********--****400----------DENEME-DENEME AA-1500 DENEME
600----------AA-900K***************700----------DENEME AA-950M DENEME
700----------AA-950M***************300----------DENEME,DENEME CC-1500 DENEME
*************************************1000----------DENEME AK-900K DENEME
*************************************1200----------DENEME,DENEME EE-1500 DENEME
*************************************2300----------DENEME,DENEME RE-1500 DENEME
*************************************2500----------DENEME,DENEME EO-1500 DENEME




Yapmak istediğim B3 deki koda göre E3 den başlayarak verilerin sonuna hücre içinde tam eşleyen arama yaparak sonuç bulunduğunda yanındaki yani d sutundeki kodu a sutuna yazdırmak.

kullandığım kod aşağıdaki gibi gibi fakat tam olarak düzgün çalışmıyor. iki satırdan sonra duruyor. Konu hakkında yardımcı olabilirseniz sevinirim. Teşekkürler şimdiden.

Sub deneme()

Dim i As Long
Dim j As Integer
Dim a
On Error Resume Next
Application.ScreenUpdating = False
For i = 3 To Cells(Rows.Count, "I").End(3).Row
a = Split(Cells(i, "I"), " ")
For j = 0 To a
If a(j) Like Cells(i, "B").Value Then
Cells(i, "A") = Replace(a(j), " ", "")
Exit For
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam", vbInformation
End Sub

 

[Korhan Ayhan]

Örnek dosyanızı paylaşım sitelerine yükleyip linkini paylaşabilirsiniz.

 

[unutkan518]

Örnek dosyanızı paylaşım sitelerine yükleyip linkini paylaşabilirsiniz.

Dosya linkini ekliyorum

DENEME.xlsm

drive.google.com

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kod_Bul()
    Dim S1 As Worksheet, Dizi As Object, Veri As Variant, Bul As Long, X As Long
    Dim Son As Long, Aranan As String, Liste As Variant, Zaman As Double

    Zaman = Timer

    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S1.Range("A3:A" & S1.Rows.Count).ClearContents

    Son = S1.Cells(S1.Rows.Count, "D").End(3).Row
    Veri = S1.Range("D3:E" & Son).Value2

    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 2)) = Veri(X, 1)
    Next

    Liste = Dizi.Keys

    Son = S1.Cells(S1.Rows.Count, "B").End(3).Row
    Veri = S1.Range("A3:B" & Son).Value2

    For X = LBound(Veri) To UBound(Veri)
        Aranan = "* " & Veri(X, 2) & " *"
        On Error Resume Next
        Bul = 0
        Bul = Application.Match(Aranan, Dizi.Keys, 0)
        On Error GoTo 0
        If Bul > 0 Then Veri(X, 1) = Dizi.Item(Liste(Bul - 1))
    Next

    S1.Range("A3").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[unutkan518]

Korhan bey öncelikle desteğiniz için çok teşekkür ederim.
Kod genel olarak çalışıyor ama şu şekilde bir durum oluştu.

B sütununda aranacak olan veri eğer E sutunu içerisinde yoksa type mismatch hatası veriyor.
Bu sorunu aşmanın bir yolu varmıdır acaba.

drive hatalı verdiği dosyayı ekliyorum.

DENEME.xlsm

drive.google.com

 

[Korhan Ayhan]

Koda küçük bir ekleme yaptım. Tekrar deneyiniz.

 

[unutkan518]

Koda küçük bir ekleme yaptım. Tekrar deneyiniz.

Çok teşekkür ederim. Elinize sağlık, mükemmel çalışıyor.

 

[unutkan518]

Koda küçük bir ekleme yaptım. Tekrar deneyiniz.

Korhan bey bir konuda daha yardım almam mümkünmü sizden
a sutununa d sutununda kodun geldiği gibi
C sutununa E sutunundaki açıkmayıda getirmek mümkünmüdür acaba. Teşekkür ederim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kod_Bul()
    Dim S1 As Worksheet, Dizi As Object, Veri As Variant, Bul As Long, X As Long
    Dim Son As Long, Aranan As String, Liste As Variant, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S1.Range("A3:A" & S1.Rows.Count).ClearContents
    S1.Range("C3:C" & S1.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, "D").End(3).Row
    Veri = S1.Range("D3:E" & Son).Value2
    
    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 2)) = Veri(X, 1)
    Next
    
    Liste = Dizi.Keys
    
    Son = S1.Cells(S1.Rows.Count, "B").End(3).Row
    Veri = S1.Range("A3:C" & Son).Value2
    
    For X = LBound(Veri) To UBound(Veri)
        Aranan = "* " & Veri(X, 2) & " *"
        On Error Resume Next
        Bul = 0
        Bul = Application.Match(Aranan, Dizi.Keys, 0)
        On Error GoTo 0
        If Bul > 0 Then
            Veri(X, 1) = Dizi.Item(Liste(Bul - 1))
            Veri(X, 3) = Liste(Bul - 1)
        End If
    Next
    
    S1.Range("A3").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    S1.Columns.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
    "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[unutkan518]

Deneyiniz.

Option Explicit

Sub Kod_Bul()
    Dim S1 As Worksheet, Dizi As Object, Veri As Variant, Bul As Long, X As Long
    Dim Son As Long, Aranan As String, Liste As Variant, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    S1.Range("A3:A" & S1.Rows.Count).ClearContents
    S1.Range("C3:C" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, "D").End(3).Row
    Veri = S1.Range("D3:E" & Son).Value2
   
    For X = LBound(Veri) To UBound(Veri)
        Dizi.Item(Veri(X, 2)) = Veri(X, 1)
    Next
   
    Liste = Dizi.Keys
   
    Son = S1.Cells(S1.Rows.Count, "B").End(3).Row
    Veri = S1.Range("A3:C" & Son).Value2
   
    For X = LBound(Veri) To UBound(Veri)
        Aranan = "* " & Veri(X, 2) & " *"
        On Error Resume Next
        Bul = 0
        Bul = Application.Match(Aranan, Dizi.Keys, 0)
        On Error GoTo 0
        If Bul > 0 Then
            Veri(X, 1) = Dizi.Item(Liste(Bul - 1))
            Veri(X, 3) = Liste(Bul - 1)
        End If
    Next
   
    S1.Range("A3").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    S1.Columns.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
    "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

çok teşekkür ederim.