• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İKİ SÜTUNU KARŞILAŞTIR BUL YARDIM

M

musaliha

Altın Üye
Katılım
3 Şubat 2021
Mesajlar
48
Excel Vers. ve Dili
2013
Merhaba ekte örnek dosyada C3 te verilen kelimelerden d sütününda eşleşen olduğunda bunu(d sütunuda yazdığı değeri) e3 te yazmasını sağlamak istiyorum.formülde yardımcı olabilirmisiniz.
 

Ekli dosyalar

Merhaba

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Doğru mu anladım bilmiyorum.

D sütunundaki isimler tekrarlanabilir, bunun anlamı o kadar kayıt var demektir.

Kod: 
Sub Makro1()
    
    Dim i   As Long, _
        c   As Range, _
        adr As String
    
    Application.ScreenUpdating = False
    
    For i = 3 To Cells(Rows.Count, "D").End(3).Row
        Application.StatusBar = i
        With Range("C:C")
            Set c = .Find(Cells(i, "D"), LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Cells(i, "E") = Cells(i, "D") & " " & Cells(i, "D")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
        Set c = Nothing
        adr = ""
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Arama Bitmiştir...."
    
End Sub
 
Merhaba.
Alternatif.

Kod: 
Sub Test()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    For Bak = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "D"), lookat:=xlPart)
        If Not Bul Is Nothing Then Cells(Bak, "E") = Bul
    Next
    MsgBox "Tamamlandı."
End Sub
 
Son düzenleme:
Muzaffer Ali' Alıntı:
Merhaba.
Alternatif.

Kod: 
Sub Test()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    For Bak = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "D"), lookat:=xlPart)
        If Not Bul Is Nothing Then Cells(Bak, "E") = Bul
    Next
    MsgBox "Tamamlandı."
End Sub
Genişletmek için tıkla ...
küçük bir farkla istediğim gibi oldu.İlgilendiğiniz için çok teşekkür ederim.
yanlış yada eksik anlatmış olmalıyım düzelteyim.

c sütünün içinde veya sadece c3te arama yapılcak. aranacaklar D sütünündaki veriler.

eşleşme sağlanınca D sütünündaki karşılığını E sütüna yazacaz ama bu c stünündaki karşılığının satırına yazılmalı.
 
Necdet' Alıntı:
Merhaba

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Doğru mu anladım bilmiyorum.

D sütunundaki isimler tekrarlanabilir, bunun anlamı o kadar kayıt var demektir.

Kod: 
Sub Makro1()
  
    Dim i   As Long, _
        c   As Range, _
        adr As String
  
    Application.ScreenUpdating = False
  
    For i = 3 To Cells(Rows.Count, "D").End(3).Row
        Application.StatusBar = i
        With Range("C:C")
            Set c = .Find(Cells(i, "D"), LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Cells(i, "E") = Cells(i, "D") & " " & Cells(i, "D")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
        Set c = Nothing
        adr = ""
      
    Next i
  
    Application.ScreenUpdating = True
  
    MsgBox "Arama Bitmiştir...."
  
End Sub
Genişletmek için tıkla ...
Merhaba Necdet Bey ilgilendiğiniz için teşekkür ederim.sizin yazdığınızı modüle ekleyip denedim.arama işlemi 2 dakika kadar sürüyor.yani ekran donuyor.sonra sonuçlar çıkıyor.veri çokluğundan değil azaltınca da aynı.bu normalmi bilemedim.

arama sonucu istediğim gibi sadece E sütüna yazılan yazı C sütündaki satırın sırasına gelse.şu anki haliyle d sütünündaki karşılığının sırasına denk geliyor.
 
Ben yine anlamadım herhalde ama bir deneyin bakalım.

Kod: 
Sub Test()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    For Bak = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "D"), lookat:=xlPart)
        If Not Bul Is Nothing Then
            If Cells(Bul.Row, "E") = "" Then
                Cells(Bul.Row, "E") = Cells(Bak, "D")
            Else
                Cells(Bul.Row, "E") = Cells(Bul.Row, "E") & ", " & Cells(Bak, "D")
            End If
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
 
Muzaffer Ali' Alıntı:
Ben yine anlamadım herhalde ama bir deneyin bakalım.

Kod: 
Sub Test()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    For Bak = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "D"), lookat:=xlPart)
        If Not Bul Is Nothing Then
            If Cells(Bul.Row, "E") = "" Then
                Cells(Bul.Row, "E") = Cells(Bak, "D")
            Else
                Cells(Bul.Row, "E") = Cells(Bul.Row, "E") & ", " & Cells(Bak, "D")
            End If
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim Muzaffer Ali Bey.Tam istediğim gibi.
 
musaliha' Alıntı:
Merhaba Necdet Bey ilgilendiğiniz için teşekkür ederim.sizin yazdığınızı modüle ekleyip denedim.arama işlemi 2 dakika kadar sürüyor.yani ekran donuyor.sonra sonuçlar çıkıyor.veri çokluğundan değil azaltınca da aynı.bu normalmi bilemedim.

arama sonucu istediğim gibi sadece E sütüna yazılan yazı C sütündaki satırın sırasına gelse.şu anki haliyle d sütünündaki karşılığının sırasına denk geliyor.
Genişletmek için tıkla ...

Merhaba,

Örnek dosyanızda D sütunu boş gibi görünse de baya bir veri var, dosyanızda onları sildim. Kod hızlandı.
Ayrıca aynı kişiye ait kayıt olduğu için hepsini birden aratıyorum, E sütununda bunları da görebilirsiniz.

Aşağıdaki kodları tekrar deneyin, olmazsa Muzaffer bey'in kodlarını kullanırsınız.

Kod: 
Sub Makro1()
    
    Dim i   As Long, _
        c   As Range, _
        adr As String
    
    Application.ScreenUpdating = False
    Range("E:E").ClearContents
    
    For i = 1 To Cells(Rows.Count, "D").End(3).Row
    
        With Range("C:C")
            Set c = .Find(Cells(i, "D"), LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Cells(c.Row, "E") = Cells(c.Row, "E") & " - " & Cells(i, "D")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
    
        adr = ""
        Set c = Nothing
        
    Next i
    
    Application.ScreenUpdating = True
    
End Sub
 
Necdet' Alıntı:
Merhaba,

Örnek dosyanızda D sütunu boş gibi görünse de baya bir veri var, dosyanızda onları sildim. Kod hızlandı.
Ayrıca aynı kişiye ait kayıt olduğu için hepsini birden aratıyorum, E sütununda bunları da görebilirsiniz.

Aşağıdaki kodları tekrar deneyin, olmazsa Muzaffer bey'in kodlarını kullanırsınız.

Kod: 
Sub Makro1()
   
    Dim i   As Long, _
        c   As Range, _
        adr As String
   
    Application.ScreenUpdating = False
    Range("E:E").ClearContents
   
    For i = 1 To Cells(Rows.Count, "D").End(3).Row
   
        With Range("C:C")
            Set c = .Find(Cells(i, "D"), LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Cells(c.Row, "E") = Cells(c.Row, "E") & " - " & Cells(i, "D")
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
   
        adr = ""
        Set c = Nothing
       
    Next i
   
    Application.ScreenUpdating = True
   
End Sub
Genişletmek için tıkla ...
Teşekkür ederim istediğim gibi oldu.sağolun.
 
merhaba aynı kodlarla ilgili bir ricam olacak sizden aşağıda belirttiğim kodlarda aradığını bulamassa devam etmeyip durması ve bulunamadı mesajını vermesini istiyorum ama çok karıştırdım çıkamadım içinden yardımcı olabilirmisiniz.

Dim Bak As Integer
Dim AraAlan As Range
Dim Bul As Range
Set AraAlan = Range("J2:J" & Cells(Rows.Count, "J").End(xlUp).Row)
For Bak = 1 To Cells(Rows.Count, "O").End(xlUp).Row
Set Bul = AraAlan.Find(what:=Cells(Bak, "O"), lookat:=xlPart)
If Not Bul Is Nothing Then
If Cells(Bul.Row, "l") = "" Then
Cells(Bul.Row, "l") = Cells(Bak, "O")
Else
Cells(Bul.Row, "l") = Cells(Bul.Row, "l") & ", " & Cells(Bak, "O")
End If
End If
Next
 
Aşağıdaki kodu deneyin.

Kod: 
Sub Test()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row)
    For Bak = 1 To Cells(Rows.Count, "D").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "D"), lookat:=xlPart)
        If Not Bul Is Nothing Then
            If Cells(Bul.Row, "E") = "" Then
                Cells(Bul.Row, "E") = Cells(Bak, "D")
            Else
                Cells(Bul.Row, "E") = Cells(Bul.Row, "E") & ", " & Cells(Bak, "D")
            End If
        else
            msgbox Cells(Bak, "D") & " bulunamadı. İşlem sonlandırılıyor."
            exit sub
        End If
    Next
    MsgBox "Tamamlandı."
End Sub
 
bu şekildede denedim ama sonuç olarak bulsada bulmasada bulamadı diyor sonlandırıyor.exit subu kaldırıncada yine bulsada bulmasada bulunamadı diyor.tamam deyincede buluyor.ben en iyisi örnek dosya atayım.
 

Ekli dosyalar

"Düğme164_Tıklat" kodlarını aşağıdaki kod ile değiştirin.

Kod: 
Sub Düğme164_Tıklat()
    Dim Bak As Integer
    Dim AraAlan As Range
    Dim Bul As Range
    Set AraAlan = Range("J2:J" & Cells(Rows.Count, "J").End(xlUp).Row)
    For Bak = 2 To Cells(Rows.Count, "N").End(xlUp).Row
        Set Bul = AraAlan.Find(what:=Cells(Bak, "N"), lookat:=xlPart)
        If Not Bul Is Nothing Then
            If Cells(Bul.Row, "l") = "" Then
                Cells(Bul.Row, "l") = Cells(Bak, "N")
            Else
                Cells(Bul.Row, "l") = Cells(Bul.Row, "l") & ", " & Cells(Bak, "N")
            End If
        Else
            MsgBox Cells(Bak, "n") & " bulunamadı. İşlem sonlandırılıyor."
            Exit Sub
        End If
    Next
    Range("L2").Copy Range("L1")
    Range("H2:L2").Cut Range("a65535").End(xlUp).Offset(1, 0)
    With Range("a65535").End(xlUp).Offset(1, 0).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("H3:L208").Cut Range("H2")
    UserForm11.show
End Sub
 
hocam yine aynı sonucu verdi yani bulsada mesaj çıkıyor bulmasada.bulsada duruyor.bulmasada.şöyle bir şey denemek istiyorum.belki bu şekilde amacıma ulaşabilirim

L2 hücresinde herhangi bir yazı var ise sonraki işleme devam etsin.
L2 hücresi boş ise sonraki koda devam etmesin.

bunun için kodu tam olarak nasıl yazmalıyım
 
Örnek dosyanızda N2 hücresinde "ENES ÖKSÜZ" yazıyor bu isim J sütununda olmadığına göre mesaj verip kodların çalışması durduruluyor.

Eğer "ENES ÖKSÜZ" N3 hücresinde olursa ve "NİSAN HALCI" N2 hücresinde olursa, bu sefer "NİSAN HALCI" J sütununda olduğu için kodlar çalışır ama bir sonraki satırda (N3'de) "ENES ÖKSÜZ" yazdığı ve J sütununda olmadığı için kodlar burada mesaj verir ve çalışmayı durdurur.

Siz farklı bir şey mi istiyorsunuz?
 
kodları çalıştırdığımızda şu an j sütünündaki ilk satırdan başlamak üzere içindeki kelimeler n sütünuyla eşleşince karşılığını L sütünundaki satırı yazıyor.küçük bir değişiklik yaparak tek tek ilerlettim.yani sadece j2 sütünunu arattırıyor hale getirdim.sonuçta eşleşince L2 sütünuna yazıyor.ancak bu arayışta sonucu bulamayıp L2yede yazamayınca sonraki safhaya geçmeden dursun istemiştim.eşleşme sağlanıp L sütünuna isim yazılı ise işleme devam etsin istemiştim.ama herşeyi birbirine karıştırdım.
 
Örnek dosya ekte.
Module9 da bulunan "Düğme164_Tıklat" kodlarında herhangi bir satırı seçin ve F8 tuşuna basarak kodları tek tek çalıştırın.
Sonucu gözlemleyin. Eğer bundan farklı bir şey istiyorsanız belirtin.
Eğer buna ek olarak istediğiniz bir şey varsa onu da ayrıca belirtin.
 

Ekli dosyalar

iyi akşamlar Muzaffer Ali bey.kodları çalıştırdığımızda j sütünündaki ilk satırda bulunan zeynep alya mutlu N sütünündaki zeynep alya mutlu ile eşleşiyor.böylece L sütünu jdeki zeynep alya mutlu yanına eşleşme sağlandığı için zeynep alya mutlu yazdı.buraya kadar amaçladığım oldu.ismi ayrıştırdığım için bundan sonra eklediğim diğer kodlarla ödeme sayfasına yönlenebiliyor ve diğer kodlarımdaa sorunsuz çalışmış oluyor.sizin kodlarınızda eşleşme sağlanmış olsada olmasada yani l sütununa eşleşme sağlanıp zeynep alya mutlu yazsa da yazmasada mesaj çıkıyor.işlem duruyor.

örneğin j sütunu ilk satırda zeynep alya mutlu değilde zeynep alya yazılı olduğunu varsaydığımızda kodlar eşleşip l sütununa bir şey yazamadığından bulunamadı uyarısı verip işlemi durdurması gerekirdi.bulunamadı diyor.işlemide sonlandırıyor.eşleşme sağlansaydı devam etmesini uyarı vermemesini istiyorum.ancak devamına eklediğim kodlara geçmiyor.

not:size verdiğim örnekte j sütünü tümüyle aratılmakta , ama ben onu sadece ilk satırı olacak şekilde değiştirdim..
 
B nu denedim galiba işe yaradı.sizide uğraştırdım.kusura bakmayın.

Sub Düğme164_Tıklat()
Dim Bak As Integer
Dim AraAlan As Range
Dim Bul As Range
Set AraAlan = Range("J2")
For Bak = 2 To Cells(Rows.Count, "N").End(xlUp).Row
Set Bul = AraAlan.Find(what:=Cells(Bak, "N"), lookat:=xlPart)
If Not Bul Is Nothing Then
If Cells(Bul.Row, "l") = "" Then
Cells(Bul.Row, "l") = Cells(Bak, "N")
Else
Cells(Bul.Row, "l") = Cells(Bul.Row, "l") & ", " & Cells(Bak, "N")
End If

End If
Next
If Range("L2").Value <> "" Then
UserForm11.Show
Else
MsgBox "İSMİ KONTROL ET", vbCritical, "HATA"

Exit Sub
End If

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst