Sütunlardaki ortak rakamları bulma

[tamer42]

Merhaba,

A ve B sütununda rakamlar içeren değerler yazılı, eğer her iki sütunda ortak rakam içeriyorsa bu rakamı verecek pratik bir yöntem arıyorum.

A1 hücresinde : 123
B1 hücresinde : 7926
2 her iki sütunda ortak: Sonuç: 2

A2 hücresinde : 1354
B2 hücresinde : 729
ortak rakam yok: Sonuç: ""

A3 hücresinde : 135
B3 hücresinde : 58
5 her iki sütunda ortak: Sonuç: 5


iki sütunu karşılaştıracak, burada ortak bir değer bulursa, bulduğu ortak değeri , ortak bir değer yoksa "" olarak sonuç verecek.

Teşekkürler,
iyi çalışmalar.

 

[muygun]

Merhaba;

Sub Kontrol()
Range("c1:c65536").ClearContents
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
bulunan = ""
If InStr(Cells(i, "A"), "0") > 0 And InStr(Cells(i, "b"), "0") > 0 Then bulunan = bulunan & "0"
If InStr(Cells(i, "A"), "1") > 0 And InStr(Cells(i, "b"), "1") > 0 Then bulunan = bulunan & "1"
If InStr(Cells(i, "A"), "2") > 0 And InStr(Cells(i, "b"), "2") > 0 Then bulunan = bulunan & "2"
If InStr(Cells(i, "A"), "3") > 0 And InStr(Cells(i, "b"), "3") > 0 Then bulunan = bulunan & "3"
If InStr(Cells(i, "A"), "4") > 0 And InStr(Cells(i, "b"), "4") > 0 Then bulunan = bulunan & "4"
If InStr(Cells(i, "A"), "5") > 0 And InStr(Cells(i, "b"), "5") > 0 Then bulunan = bulunan & "5"
If InStr(Cells(i, "A"), "6") > 0 And InStr(Cells(i, "b"), "6") > 0 Then bulunan = bulunan & "6"
If InStr(Cells(i, "A"), "7") > 0 And InStr(Cells(i, "b"), "7") > 0 Then bulunan = bulunan & "7"
If InStr(Cells(i, "A"), "8") > 0 And InStr(Cells(i, "b"), "8") > 0 Then bulunan = bulunan & "8"
If InStr(Cells(i, "A"), "9") > 0 And InStr(Cells(i, "b"), "9") > 0 Then bulunan = bulunan & "9"

Cells(i, "c") = bulunan
If Cells(i, "c") = "" Then Cells(i, "c") = """"
Next i
End Sub


Not: Sıfırı kontrol dışına almak isterseniz ilk if mukayese satırını silin.
İyi çalışmalar.

 

[Necdet]

Merhaba,

Alternatif olsun.

Aşağıdaki kodları dener misiniz.

Sub Karsilastir()

    Dim i   As Long, _
        j   As Integer, _
        k   As Integer
    
    Range("C:C").ClearContents
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        For j = 1 To Len(Cells(i, "A"))
            For k = 1 To Len(Cells(i, "B"))
            Debug.Print Mid(Cells(i, "A"), j, 1) & " " & Mid(Cells(i, "B"), k, 1)
                If Mid(Cells(i, "A"), j, 1) = Mid(Cells(i, "B"), k, 1) Then Cells(i, "C") = Cells(i, "C") & " " & Mid(Cells(i, "A"), j, 1)
            Next k
        Next j
        
    Next i
    
End Sub

 

[tamer42]

Merhaba,

Alternatif olsun.

Aşağıdaki kodları dener misiniz.

Sub Karsilastir()

    Dim i   As Long, _
        j   As Integer, _
        k   As Integer
   
    Range("C:C").ClearContents
   
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        For j = 1 To Len(Cells(i, "A"))
            For k = 1 To Len(Cells(i, "B"))
            Debug.Print Mid(Cells(i, "A"), j, 1) & " " & Mid(Cells(i, "B"), k, 1)
                If Mid(Cells(i, "A"), j, 1) = Mid(Cells(i, "B"), k, 1) Then Cells(i, "C") = Cells(i, "C") & " " & Mid(Cells(i, "A"), j, 1)
            Next k
        Next j
       
    Next i
   
End Sub

Sn Muygun, Sn. Necdet hocam her ikinize de teşekkürler

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Ortak_Veriler()
    Dim Son As Long, Veri As Variant, X As Long, Uzunluk As Integer, Y As Integer, Ortak As String, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Veri = Range("A1:B" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Len(Veri(X, 1)) < Len(Veri(X, 2)) Then
            Uzunluk = Len(Veri(X, 1))
            For Y = 1 To Uzunluk
                If InStr(1, Veri(X, 2), Mid(Veri(X, 1), Y, 1)) > 0 Then
                    If Ortak = "" Then
                        Ortak = Mid(Veri(X, 1), Y, 1)
                    Else
                        Ortak = Ortak & "-" & Mid(Veri(X, 1), Y, 1)
                    End If
                End If
            Next
        Else
            Uzunluk = Len(Veri(X, 2))
            For Y = 1 To Uzunluk
                If InStr(1, Veri(X, 1), Mid(Veri(X, 2), Y, 1)) > 0 Then
                    If Ortak = "" Then
                        Ortak = Mid(Veri(X, 2), Y, 1)
                    Else
                        Ortak = Ortak & "-" & Mid(Veri(X, 2), Y, 1)
                    End If
                End If
            Next
        End If
        
        Liste(X, 1) = Ortak
        Ortak = ""
    Next
    
    Range("C1").Resize(Son) = Liste

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

 

[Murat OSMA]

Alternatif;

Sub Osma()
    On Local Error Resume Next
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        ara = Cells(i, "A").Value
        For a = 1 To Len(ara)
            Set bul = Range("B" & i).Find(Mid(ara, a, 1), , , 2)
            If Not bul Is Nothing Then
                Emre = bul.Address
                Do
                    Set bul = Range("B" & i).Find(bul)
                    yaz = yaz & Mid(ara, a, 1) & "|"
                Loop While Not bul Is Nothing And Emre <> bul.Address
            End If
        Next a
        Cells(i, 3) = Left(yaz, Len(yaz) - 1)
        yaz = Empty
    Next i
End Sub

 

[tamer42]

Alternatif;

Sub Osma()
    On Local Error Resume Next
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        ara = Cells(i, "A").Value
        For a = 1 To Len(ara)
            Set bul = Range("B" & i).Find(Mid(ara, a, 1), , , 2)
            If Not bul Is Nothing Then
                Emre = bul.Address
                Do
                    Set bul = Range("B" & i).Find(bul)
                    yaz = yaz & Mid(ara, a, 1) & "|"
                Loop While Not bul Is Nothing And Emre <> bul.Address
            End If
        Next a
        Cells(i, 3) = Left(yaz, Len(yaz) - 1)
        yaz = Empty
    Next i
End Sub

Korhan ve Murat Hocam ilginize teşekkürler....

 

[veyselemre]

Sub Kontrol()
    Range("C:C").ClearContents
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        bulunan = ""
        For ii = 0 To 9
            If InStr(Cells(i, "A"), ii) > 0 And InStr(Cells(i, "b"), ii) > 0 Then bulunan = bulunan & ii
        Next ii
        Cells(i, "c") = bulunan
    Next i
End Sub

 

[Necdet]

Merhaba,

Bir seçenek daha sunayım.

Sub Karsilastir()

    Dim i As Long
    Dim j As Integer
    Dim k As Integer
    Dim t As String
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        t = ""
        For j = 1 To Len(Cells(i, "A"))
            k = Int(Mid(Cells(i, "A"), j, 1))
            If Cells(i, "B") Like "*" & k & "*" Then t = t & " " & k
        Next j
        If Not t = "" Then Cells(i, "C") = t
        
    Next i
    
End Sub

 

[Murat OSMA]

Bu da formülle çözüm olsun..

Office 2019 ve sonrası için..

=METİNBİRLEŞTİR("-";1;EĞERHATA(PARÇAAL($B1;MBUL(PARÇAAL($A1;SATIR(DOLAYLI("1:"&UZUNLUK($A1)));1);$B1);1);""))