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

musaliha · 17 Aralık 2021

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.

Necdet · 18 Aralık 2021

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

Muzaffer Ali · 18 Aralık 2021

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

musaliha · 18 Aralık 2021

musaliha · 18 Aralık 2021

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

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ı.

musaliha · 18 Aralık 2021

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

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.

Muzaffer Ali · 19 Aralık 2021

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

musaliha · 19 Aralık 2021

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

Çok teşekkür ederim Muzaffer Ali Bey.Tam istediğim gibi.

Necdet · 19 Aralık 2021

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.

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

musaliha · 21 Aralık 2021

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

Teşekkür ederim istediğim gibi oldu.sağolun.

musaliha · 6 Ocak 2022

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

Muzaffer Ali · 7 Ocak 2022

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

musaliha · 7 Ocak 2022

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.

Muzaffer Ali · 7 Ocak 2022

"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

musaliha · 7 Ocak 2022

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

Muzaffer Ali · 7 Ocak 2022

Ö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?

musaliha · 7 Ocak 2022

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.

Muzaffer Ali · 7 Ocak 2022

Ö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.

musaliha · 7 Ocak 2022

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..

musaliha · 7 Ocak 2022

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

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

musaliha

Ekli dosyalar

Necdet

Moderatör

Muzaffer Ali

Destek Ekibi

musaliha

musaliha

musaliha

Muzaffer Ali

Destek Ekibi

musaliha

Necdet

Moderatör

musaliha

musaliha

Muzaffer Ali

Destek Ekibi

musaliha

Ekli dosyalar

Muzaffer Ali

Destek Ekibi

musaliha

Muzaffer Ali

Destek Ekibi

musaliha

Muzaffer Ali

Destek Ekibi

Ekli dosyalar

musaliha

musaliha