İki sütundaki eşleşen adları üçüncü sütuna yazdırma

Xavay · 2 Mayıs 2023

Selamlar.
Arkadaşlar çok yerde arasam da bulduklarım hiç çalışmadı çok bilgim olmadığı için de kodları düzenleme şansım kısıtlı oldu maalesef ki.

Meselenin özü şu; benim A sütunum var ve burada ad ve soyad var birleşik olarak. Bir de B sütunum var ve buradaysa birden fazla isim var hepsi de virgülle ayrılmış.
Ben A ve B sütununu karşılaştırıp A'da bulunan ismin eşleştiği B sütunundaki ismi C sütununa eklemek istiyorum.
Zannedersem örnek verince daha iyi anlatmış olurum.

Burada mesela hepsi virgülle ayrılmış B sütunundakiler yani. Örneğin ALFAROMEO ile alfa.romeo aynı olduğu için (mümkünse alfa.romeo'yu kırmızı yapıp) C'ye kopyalamak istiyorum.

Tüm satırlarım bu şekilde. Ne kadar yaptıysam sadece B'de tek bir isim olunca çalıştı. Böyle olunca hiç çalışmadı.

Yardımcı olabilecek birileri var mıdır?

Şimdiden teşekkür ederim.

RBozkurt · 2 Mayıs 2023

Nokta var arasında. C'de noktalı olması şart mı?

dedenet · 2 Mayıs 2023

Tam olarak anlayabilmek için aşağı satırları daha çok doldurur musun. bu haliyle çözüm bulmak güç.

Xavay · 3 Mayıs 2023

RBozkurt' Alıntı:
Nokta var arasında. C'de noktalı olması şart mı?

Şöyle ki, her virgül arası bir isim. Yani adm bir isim, alfa.romeo ve maked, robus ve diğerleri de. Diğer satırlarda da böyle isimler var. Eğer karışıklık yaratmayacaksa noktasız da olabilir. Örneğin ALFAROMEO ile alfa.romeo eşleşince aynı olduğu için C sütununa alfa.romeo olarak da yazabilir alfa romeo olarak da. Bunda bir sorun yok. İlla nokta olması gerekmiyor.

dedenet' Alıntı:
Tam olarak anlayabilmek için aşağı satırları daha çok doldurur musun. bu haliyle çözüm bulmak güç.

Bilerek birden fazla satır doldurmadım çünkü hepsinin formatı aynı. Ama tabii ki daha açıklığa kavuşturmak için aşağıdaki örneği bırakabilirim.
Eğer yetersiz olursa yine ekleyebilirim.

dEdE · 3 Mayıs 2023

Merhaba,
C sütununa da istediğiniz/beklediğiniz sonucu yazsaydınız daha anlaşılır olurdu.
Ben sorunuzu böyle anladım. #4 numaralı mesaja eklediğiniz örnek üzerinde dener misiniz?

C++:

Sub Test()
ss = Cells(Rows.Count, "B").End(3).Row
Dim myArr3() As String
myArr1 = Range("A1:A" & ss)
myArr2 = Range("B1:B" & ss)

For i = LBound(myArr2) To UBound(myArr2)
    ReDim Preserve myArr3(1 To ss)
    myArr3(i) = Replace(myArr2(i, 1), ".", "")
    x = Split(myArr3(i), ",")
        For j = 0 To UBound(x)
            If myArr1(i, 1) = Evaluate("=UPPER(""" & x(j) & """)") Then _
                Cells(i, 3) = Evaluate("=UPPER(""" & x(j) & """)")
        Next j
Next i
    Range("C1:C" & ss).Font.Color = vbRed
End Sub

Xavay · 3 Mayıs 2023

dEdE' Alıntı:
Merhaba,
C sütununa da istediğiniz/beklediğiniz sonucu yazsaydınız daha anlaşılır olurdu.
Ben sorunuzu böyle anladım. #4 numaralı mesaja eklediğiniz örnek üzerinde dener misiniz?

C++:

Sub Test() ss = Cells(Rows.Count, "B").End(3).Row Dim myArr3() As String myArr1 = Range("A1:A" & ss) myArr2 = Range("B1:B" & ss) For i = LBound(myArr2) To UBound(myArr2) ReDim Preserve myArr3(1 To ss) myArr3(i) = Replace(myArr2(i, 1), ".", "") x = Split(myArr3(i), ",") For j = 0 To UBound(x) If myArr1(i, 1) = Evaluate("=UPPER(""" & x(j) & """)") Then _ Cells(i, 3) = Evaluate("=UPPER(""" & x(j) & """)") Next j Next i Range("C1:C" & ss).Font.Color = vbRed End Sub

Öncelikle verdiğiniz kod ve zahmetiniz için müteşekkirim.
Bu kodu çalıştırdım ve çalışan ilk kod olması beni çok mutlu etti açıkçası.
Ama şöyle, bu kod çalıştıktan sonra C sütununa A'daki değeri yazdırdı. Örneğin LEVOPERA yazdı, bense lev.opera veyahut lev opera şeklinde olmasını istiyordum.
Şimdi C sütununa eşleşen değerin B'deki halini yazdırabilir mi? Ve eğer mümkünse bununla beraber B'nin kendisinde o yazıyı kırmızı yapsın.

Tam olarak aşağıdaki gibi bir çıktı bekliyordum hani kodu çalıştırdıktan sonra böyle görünsün.
Ama B sütunundaki kırmızı olmasa da olur, önemli olan C sütununa eşleşen değerin B'deki halini yazsın, noktalı veya noktasız farketmez.

Tekrardan çok teşekkür ediyorum, Allah razı olsun. Umarım dediklerimin de yapılabilme olasılığı vardır.

dEdE · 3 Mayıs 2023

Merhaba,
Sorunuzu tam olarak anlayamamıştım. Yukarıdaki örneğiniz net ve anlaşılır olmuş.
B sütunundaki renklendirme ve C sütunundaki nokta da yapılabilir ama daha uzun bir kod gerektirir.
Basit ve kısa bir çözüm için Cells(i, 3) = Evaluate("=UPPER(""" & x(j) & """)") satırını Cells(i, 3) = x(j) satırı ile değiştirerek dener misiniz?

Xavay · 3 Mayıs 2023

dEdE' Alıntı:
Merhaba,
Sorunuzu tam olarak anlayamamıştım. Yukarıdaki örneğiniz net ve anlaşılır olmuş.
B sütunundaki renklendirme ve C sütunundaki nokta da yapılabilir ama daha uzun bir kod gerektirir.
Basit ve kısa bir çözüm için Cells(i, 3) = Evaluate("=UPPER(""" & x(j) & """)") satırını Cells(i, 3) = x(j) satırı ile değiştirerek dener misiniz?

Çok teşekkür ediyorum. Evet doğru şekilde çalışıyor. Tam da istediğim gibi.

Lakin ufak bir sorunum daha çıktı.

Mesela ALFAROMEO için alfa.romeo'yu doğru bulup C'ye yazıyor ama romeo.alfa olunca yanlış olarak görüyor.
alfa.rom (ya da başka bir örnek gerekirse tech.support yerine tech.suppo) olunca da eşleşmiyor.

Bir de son olarak bu (A sütunundaki) adların sonunda 1 ya da 2 rakamı olunca da C sütununa yazdırsın, böyle bir şey mümkün mü?
(Mesela ALFAROMEO1 ile alfa.romeo'yu aynı görsün ve C'ye yazsın.)

Evet, farkındayım az az da olsa çok şey istemiş oldum. Şu son dediklerim hallolursa mükemmel ötesi olur.
Olsa da olmasa da teşekkür ediyorum, minnettarım size.

Xavay · 4 Mayıs 2023

@dEdE , hocam yardımcı olabilme şansınız var mıdır?

Xavay · 4 Mayıs 2023

Yardımcı olabilecek yok mu arkadaşlar?

Necdet · 5 Mayıs 2023

Merhaba,

https://www.microsoft.com/en-us/download/confirmation.aspx?id=15011 adresinden
Fuzzy Lookup eklentisini indirip kullanabilirsiniz.

Kullanımını Youtube da arayarak öğrenebilirsiniz.

Youtube Linki için tıklayınız (30. dakikadan sonra anlatılıyor)

Xavay · 5 Mayıs 2023

Necdet' Alıntı:
Merhaba,

https://www.microsoft.com/en-us/download/confirmation.aspx?id=15011 adresinden
Fuzzy Lookup eklentisini indirip kullanabilirsiniz.

Kullanımını Youtube da arayarak öğrenebilirsiniz.

Youtube Linki için tıklayınız (30. dakikadan sonra anlatılıyor)

Teşekkür ediyorum. İzledim videoyu ama benim anlattığım şey bundan farklı.
Anladığım kadarıyla bu işlemde aynı (benzer) isimleri yan yana getiriyor. Ama bu benim işime yaramaz.
Yine de ilgi ve alakanız için teşekkür ederim.

necati · 5 Mayıs 2023

Merhaba, Sn. dEdE'nin kodundan uyarlayarak

Kod:

Sub Test()
Dim myArr3() As String
Dim i As Integer, j As Integer
Dim bas As Integer, son As Integer

ss = Cells(Rows.Count, "B").End(3).Row
myArr1 = Range("A1:A" & ss)
myArr2 = Range("B1:B" & ss)
ReDim Preserve myArr3(1 To ss)

For i = LBound(myArr2) To UBound(myArr2)
    y = Split(myArr2(i, 1), ",")
    myArr3(i) = Replace(myArr2(i, 1), ".", "")
    x = Split(myArr3(i), ",")
    bas = 1: son = 0
        For j = 0 To UBound(x)
        If Trim(myArr1(i, 1)) = Trim(Evaluate("=UPPER(""" & x(j) & """)")) Then
        Cells(i, 3) = y(j)
            If InStr(bas, y(j), Cells(i, 3)) Then
                bas = InStr(1, Cells(i, 2), y(j))
                son = Len(y(j))
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Color = vbRed
                bas = son + 1
            End If
        End If
        Next j
Next i

MsgBox "İşlem tamam", vbInformation

End Sub

Xavay · 5 Mayıs 2023

necati' Alıntı:

Merhaba, Sn. dEdE'nin kodundan uyarlayarak

Kod:

Sub Test()
Dim myArr3() As String
Dim i As Integer, j As Integer
Dim bas As Integer, son As Integer

ss = Cells(Rows.Count, "B").End(3).Row
myArr1 = Range("A1:A" & ss)
myArr2 = Range("B1:B" & ss)
ReDim Preserve myArr3(1 To ss)

For i = LBound(myArr2) To UBound(myArr2)
    y = Split(myArr2(i, 1), ",")
    myArr3(i) = Replace(myArr2(i, 1), ".", "")
    x = Split(myArr3(i), ",")
    bas = 1: son = 0
        For j = 0 To UBound(x)
        If Trim(myArr1(i, 1)) = Trim(Evaluate("=UPPER(""" & x(j) & """)")) Then
        Cells(i, 3) = y(j)
            If InStr(bas, y(j), Cells(i, 3)) Then
                bas = InStr(1, Cells(i, 2), y(j))
                son = Len(y(j))
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Color = vbRed
                bas = son + 1
            End If
        End If
        Next j
Next i

MsgBox "İşlem tamam", vbInformation

End Sub

Teşekkür ederim, tam da istediğim gibi çalışıyor ama yukarıda da dediğim gibi alfa.romeo yerine romeo.alfa olunca farklı isimler sanıyor ve ALFAROMEO ile eşleştirmiyor.
Ya da mesela ALFAROMEO1 olunca alfa.romeo (ya da romeo.alfa) ile farklı isimler olduğunu anlıyor.

necati · 6 Mayıs 2023

Xavay' Alıntı:
Teşekkür ederim, tam da istediğim gibi çalışıyor ama yukarıda da dediğim gibi alfa.romeo yerine romeo.alfa olunca farklı isimler sanıyor ve ALFAROMEO ile eşleştirmiyor.
Ya da mesela ALFAROMEO1 olunca alfa.romeo (ya da romeo.alfa) ile farklı isimler olduğunu anlıyor.

Kelimeye ekli sayılar varsa ve ters yazılan çift kelimeler için:

Kod:

Option Compare Text
Sub Test2()
Dim myArr3() As String, myArr4() As String
Dim i As Integer, k As Integer, str As String
Dim bas As Integer, son As Integer

ss = Cells(Rows.Count, "B").End(3).Row
Range("c1:c" & ss).Clear

For i = 1 To ss
    Range("A" & i).Value = metinal(Range("A" & i))
Next i

myArr1 = Range("A1:A" & ss)
myArr2 = Range("B1:B" & ss)

For i = LBound(myArr2) To UBound(myArr2)
    y = Split(myArr2(i, 1), ",")

    ReDim Preserve myArr3(0 To UBound(y))
    ReDim Preserve myArr4(0 To UBound(y))
    
        For k = LBound(y) To UBound(y)
            str = Application.Clean(Trim(y(k)))
            
            If InStr(1, str, ".") Then
                x = Split(y(k), ".")
            ElseIf InStr(1, str, " ") Then
                x = Split(y(k), " ")
            End If
            
            myArr3(k) = x(LBound(x)) & x(UBound(x)) 'düzden yazılan
            myArr4(k) = x(UBound(x)) & x(LBound(x)) 'tersten yazılan
            
            If myArr1(i, 1) = myArr4(k) _
            Or myArr1(i, 1) = myArr3(k) Then
                Cells(i, 3) = Cells(i, 3) & "," & str
                bas = InStr(1, Cells(i, 2), y(k))
                son = Len(y(k))
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Bold = True
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Color = vbRed
                bas = son + 1
            End If
        Next k

Erase myArr3: Erase myArr4
On Error Resume Next
Cells(i, 3) = Mid(Cells(i, 3), 2, Len(Cells(i, 3)) - 1)
Next i

MsgBox "İşlem tamam", vbInformation

End Sub

Function metinal(hcr As String)
Dim uz As Integer
uz = Len(hcr)
For i = 1 To uz
If Not IsNumeric(Mid(hcr, i, 1)) Then sonuc = sonuc & Mid(hcr, i, 1)
Next i
metinal = Application.Clean(Trim(sonuc))
End Function

Korhan Ayhan · 6 Mayıs 2023

Alternatif ;

C++:

Option Explicit

Sub Find_Text()
    Dim WF As WorksheetFunction, Rng As Range
    Dim My_Text As Variant, My_Sub_Text As Variant
    Dim No As Integer, X As Integer, Y As Integer
    
    Application.ScreenUpdating = 0
    
    Set WF = WorksheetFunction
    
    Range("C:C").ClearContents
    Range("B:B").Font.Color = False
    Range("B:B").Font.Bold = False
    
    For Each Rng In Range("B1:B" & Cells(Rows.Count, 2).End(3).Row)
        X = 0
        Y = 0
        For Each My_Text In Split(Rng.Value, ",")
            If InStr(1, My_Text, ".") > 0 Then
                For Each My_Sub_Text In Split(My_Text, ".")
                    On Error Resume Next
                    No = 0
                    No = WF.Search(My_Sub_Text, Rng.Offset(0, -1).Value, 1)
                    On Error GoTo 0
                    If No > 0 Then X = X + 1
                Next
                If X = UBound(Split(My_Text, ".")) + 1 Then
                    Rng.Characters(Y + 1, Len(My_Text)).Font.ColorIndex = 3
                    Rng.Characters(Y + 1, Len(My_Text)).Font.Bold = True
                    Rng.Offset(0, 1).Value = IIf(Rng.Offset(0, 1).Value = "", My_Text, Rng.Offset(0, 1).Value & "," & My_Text)
                End If
            Else
                On Error Resume Next
                No = 0
                No = WF.Search(Replace(My_Text, ".", ""), Rng.Offset(0, -1).Value, 1)
                On Error GoTo 0
                If No > 0 Then
                    Rng.Characters(Y + 1, Len(My_Text)).Font.ColorIndex = 3
                    Rng.Characters(Y + 1, Len(My_Text)).Font.Bold = True
                    Rng.Offset(0, 1).Value = IIf(Rng.Offset(0, 1).Value = "", My_Text, Rng.Offset(0, 1).Value & "," & My_Text)
                End If
            End If
            Y = Y + Len(My_Text) + 1
        Next
    Next

    Columns(3).AutoFit
    
    Set WF = Nothing

    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Xavay · 8 Mayıs 2023

necati' Alıntı:

Kelimeye ekli sayılar varsa ve ters yazılan çift kelimeler için:

Kod:

Option Compare Text
Sub Test2()
Dim myArr3() As String, myArr4() As String
Dim i As Integer, k As Integer, str As String
Dim bas As Integer, son As Integer

ss = Cells(Rows.Count, "B").End(3).Row
Range("c1:c" & ss).Clear

For i = 1 To ss
    Range("A" & i).Value = metinal(Range("A" & i))
Next i

myArr1 = Range("A1:A" & ss)
myArr2 = Range("B1:B" & ss)

For i = LBound(myArr2) To UBound(myArr2)
    y = Split(myArr2(i, 1), ",")

    ReDim Preserve myArr3(0 To UBound(y))
    ReDim Preserve myArr4(0 To UBound(y))
   
        For k = LBound(y) To UBound(y)
            str = Application.Clean(Trim(y(k)))
           
            If InStr(1, str, ".") Then
                x = Split(y(k), ".")
            ElseIf InStr(1, str, " ") Then
                x = Split(y(k), " ")
            End If
           
            myArr3(k) = x(LBound(x)) & x(UBound(x)) 'düzden yazılan
            myArr4(k) = x(UBound(x)) & x(LBound(x)) 'tersten yazılan
           
            If myArr1(i, 1) = myArr4(k) _
            Or myArr1(i, 1) = myArr3(k) Then
                Cells(i, 3) = Cells(i, 3) & "," & str
                bas = InStr(1, Cells(i, 2), y(k))
                son = Len(y(k))
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Bold = True
                Cells(i, 2).Characters(Start:=bas, Length:=son).Font.Color = vbRed
                bas = son + 1
            End If
        Next k

Erase myArr3: Erase myArr4
On Error Resume Next
Cells(i, 3) = Mid(Cells(i, 3), 2, Len(Cells(i, 3)) - 1)
Next i

MsgBox "İşlem tamam", vbInformation

End Sub

Function metinal(hcr As String)
Dim uz As Integer
uz = Len(hcr)
For i = 1 To uz
If Not IsNumeric(Mid(hcr, i, 1)) Then sonuc = sonuc & Mid(hcr, i, 1)
Next i
metinal = Application.Clean(Trim(sonuc))
End Function

Korhan Ayhan' Alıntı:

Alternatif ;

C++:

Option Explicit

Sub Find_Text()
    Dim WF As WorksheetFunction, Rng As Range
    Dim My_Text As Variant, My_Sub_Text As Variant
    Dim No As Integer, X As Integer, Y As Integer
   
    Application.ScreenUpdating = 0
   
    Set WF = WorksheetFunction
   
    Range("C:C").ClearContents
    Range("B:B").Font.Color = False
    Range("B:B").Font.Bold = False
   
    For Each Rng In Range("B1:B" & Cells(Rows.Count, 2).End(3).Row)
        X = 0
        Y = 0
        For Each My_Text In Split(Rng.Value, ",")
            If InStr(1, My_Text, ".") > 0 Then
                For Each My_Sub_Text In Split(My_Text, ".")
                    On Error Resume Next
                    No = 0
                    No = WF.Search(My_Sub_Text, Rng.Offset(0, -1).Value, 1)
                    On Error GoTo 0
                    If No > 0 Then X = X + 1
                Next
                If X = UBound(Split(My_Text, ".")) + 1 Then
                    Rng.Characters(Y + 1, Len(My_Text)).Font.ColorIndex = 3
                    Rng.Characters(Y + 1, Len(My_Text)).Font.Bold = True
                    Rng.Offset(0, 1).Value = IIf(Rng.Offset(0, 1).Value = "", My_Text, Rng.Offset(0, 1).Value & "," & My_Text)
                End If
            Else
                On Error Resume Next
                No = 0
                No = WF.Search(Replace(My_Text, ".", ""), Rng.Offset(0, -1).Value, 1)
                On Error GoTo 0
                If No > 0 Then
                    Rng.Characters(Y + 1, Len(My_Text)).Font.ColorIndex = 3
                    Rng.Characters(Y + 1, Len(My_Text)).Font.Bold = True
                    Rng.Offset(0, 1).Value = IIf(Rng.Offset(0, 1).Value = "", My_Text, Rng.Offset(0, 1).Value & "," & My_Text)
                End If
            End If
            Y = Y + Len(My_Text) + 1
        Next
    Next

    Columns(3).AutoFit
   
    Set WF = Nothing

    Application.ScreenUpdating = 1
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Çok teşekkür ederim her birinize. Deneyeceğim bunları. Allah razı olsun.

İki sütundaki eşleşen adları üçüncü sütuna yazdırma

Xavay

RBozkurt

𐱅𐰇𐰼𐰚

dedenet

Xavay

dEdE

Destek Ekibi

Xavay

dEdE

Destek Ekibi

Xavay

Xavay

Xavay

Necdet

Moderatör

Xavay

necati

Xavay

necati

Korhan Ayhan

Administrator

Xavay