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

U

unutkan518

Katılım
5 Eylül 2013
Mesajlar
29
Excel Vers. ve Dili
2016 Türkçe
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
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek dosyanızı paylaşım sitelerine yükleyip linkini paylaşabilirsiniz.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
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
 
U

unutkan518

Katılım
5 Eylül 2013
Mesajlar
29
Excel Vers. ve Dili
2016 Türkçe
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.

drive.google.com

DENEME.xlsm

drive.google.com drive.google.com
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Koda küçük bir ekleme yaptım. Tekrar deneyiniz.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,112
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
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
 
U

unutkan518

Katılım
5 Eylül 2013
Mesajlar
29
Excel Vers. ve Dili
2016 Türkçe
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst