• DİKKAT

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

Yerleri farklı ama aynı karakter sayıdaki verileri karşılaştırmak

B

baydeniro

Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Merhaba Arkadaşlar;
Görseldeki gibi sonuçları makro ile almak mümkün mü ?
1.kelime ile 2.kelimedeki harfler aynı ama yerleri değişikse EŞİT, 1 harf bile farklı ise DEĞİL sonucu almak.

224067
 
Deneyiniz. Hata varsa düzeltelim.
C++: 
Sub Karşılaştır()
For i = 2 To Range("B" & Rows.Count).End(3).Row
    If Len(Range("B" & i)) <> Len(Range("C" & i)) Then GoTo DEĞİL
    For k = 1 To Len(Range("B" & i))
        If Len(Replace(Range("B" & i), Mid(Range("B" & i), i, 1), "")) <> _
        Len(Replace(Range("C" & i), Mid(Range("B" & i), i, 1), "")) Then GoTo DEĞİL
    Next k
    Range("D" & i) = "eşit"
    GoTo DEVAM
DEĞİL:
    Range("D" & i) = "değil"
DEVAM:
Next i
End Sub
 
NextLevel' Alıntı:
Deneyiniz. Hata varsa düzeltelim.
C++: 
Sub Karşılaştır()
For i = 2 To Range("B" & Rows.Count).End(3).Row
    If Len(Range("B" & i)) <> Len(Range("C" & i)) Then GoTo DEĞİL
    For k = 1 To Len(Range("B" & i))
        If Len(Replace(Range("B" & i), Mid(Range("B" & i), i, 1), "")) <> _
        Len(Replace(Range("C" & i), Mid(Range("B" & i), i, 1), "")) Then GoTo DEĞİL
    Next k
    Range("D" & i) = "eşit"
    GoTo DEVAM
DEĞİL:
    Range("D" & i) = "değil"
DEVAM:
Next i
End Sub
Genişletmek için tıkla ...
üstad teşekkür ederim. Beklenen sonuç bu değil ama bu kodun da kullanılabileceği yerler hakkında çağrışım yaptı. teşekkür ederim.
Bu kod; aynı uzunluktaki 2 veride 1 harf bile benziyorsa EŞİT diyor. Ama beklenen sonuç, 2 veride 1 harf bile benMEziyorsa "DEĞİL" demesi!
 
Ben deniyorum, dediğiniz gibi sonuç almıyorum.
"2 veride 1 harf bile benMEziyorsa "DEĞİL" demesi!" Yazdığım kodda da geçerli
Hata verdiğini söylediğiniz kelimeleri ya da exceli paylaşır mısınız?
 
NextLevel' Alıntı:
Ben deniyorum, dediğiniz gibi sonuç almıyorum.
"2 veride 1 harf bile benMEziyorsa "DEĞİL" demesi!" Yazdığım kodda da geçerli
Hata verdiğini söylediğiniz kelimeleri ya da exceli paylaşır mısınız?
Genişletmek için tıkla ...
teşekkürler NextLEvel üstad. Örnek dosya ekledim.
 

Ekli dosyalar

If Len(Replace(Range("B" & i), Mid(Range("B" & i), k, 1), "")) <> _
Len(Replace(Range("C" & i), Mid(Range("B" & i), k, 1), "")) Then GoTo DEĞİL

IF satırını yukarıdakiyle değiştirin.
 
NextLevel' Alıntı:
If Len(Replace(Range("B" & i), Mid(Range("B" & i), k, 1), "")) <> _
Len(Replace(Range("C" & i), Mid(Range("B" & i), k, 1), "")) Then GoTo DEĞİL

IF satırını yukarıdakiyle değiştirin.
Genişletmek için tıkla ...
çok teşekkür ederim üstadım, şimdi oldu. Diğeri de bir yerde işe yarayacaktır. 2 harika kod için sağ olun var olun, sağlıcakla kalın
 
Merhaba,

Bir seçenek te benden. Her iki sözcük karmaşıkta olsa büyük küçük harfte bile karşılaştırma yapar.

Kod: 
Sub Karşılaştır()

    Dim i   As Long, _
        t1  As String, _
        t2  As String
   
    For i = 2 To Range("B" & Rows.Count).End(3).Row
        t1 = SozcukSrl(Cells(i, "B"))
        t2 = SozcukSrl(Cells(i, "C"))
        Cells(i, "D") = t1 = t2
    Next i

End Sub

Kod: 
Function SozcukSrl(Txt)

  Dim arr
  Dim strTemp As String
  Dim i As Integer
  Dim j As Integer
  Dim lngMin As Integer
  Dim lngMax As Integer

  Txt = Application.WorksheetFunction.Trim(Txt)
  Txt = UCase(Replace(Replace(Txt, "i", "İ"), "ı", "I"))

  ReDim arr(1 To Len(Txt))

  For i = 1 To Len(Txt)
    arr(i) = Mid(Txt, i, 1)
  Next i

  lngMin = LBound(arr)
  lngMax = UBound(arr)

  For i = lngMin To lngMax - 1
    For j = i + 1 To lngMax
      If arr(i) > arr(j) Then
        strTemp = arr(i)
        arr(i) = arr(j)
        arr(j) = strTemp
      End If
    Next j
  Next i
   
    Txt = ""
    For i = 1 To UBound(arr)
        Txt = Txt & arr(i)
    Next i
   
    SozcukSrl = Txt
   
End Function
 
Son düzenleme:
Kod: 
Sub Test()

    For i = 2 To Range("B" & Rows.Count).End(3).Row
        al1 = Range("B" & i).Value
        al2 = Range("C" & i).Value

        Do While al1 <> ""
            If Len(al1) = Len(al2) Then
                deg = Left(al1, 1)
                al1 = Replace(al1, deg, "")
                al2 = Replace(al2, deg, "")
                If Len(al1) < 2 And al1 = al2 Then
                    Cells(i, "E").Value = "EŞİT"
                    GoTo DEVAM
                End If
            Else
                Exit Do
            End If
        Loop

        Cells(i, "E").Value = "DEĞİL"
DEVAM:
    Next i
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub Test()

    For i = 2 To Range("B" & Rows.Count).End(3).Row
        al1 = Range("B" & i).Value
        al2 = Range("C" & i).Value

        Do While al1 <> ""
            If Len(al1) = Len(al2) Then
                deg = Left(al1, 1)
                al1 = Replace(al1, deg, "")
                al2 = Replace(al2, deg, "")
                If Len(al1) < 2 And al1 = al2 Then
                    Cells(i, "E").Value = "EŞİT"
                    GoTo DEVAM
                End If
            Else
                Exit Do
            End If
        Loop

        Cells(i, "E").Value = "DEĞİL"
DEVAM:
    Next i
End Sub
Genişletmek için tıkla ...
veyselemre üstadım elinize, aklınıza sağlık. Harika bir kod. Güçlü bir alternatifimiz oldu. Sağlıcakla kalın
 
Necdet' Alıntı:
Merhaba,

Bir seçenek te benden. Her iki sözcük karmaşık olsa bile karşılaştırma yapar.

Kod: 
Sub Karşılaştır()

    Dim i   As Long, _
        t1  As String, _
        t2  As String
   
    For i = 2 To Range("B" & Rows.Count).End(3).Row
        t1 = SozcukSrl(Cells(i, "B"))
        t2 = SozcukSrl(Cells(i, "C"))
        Cells(i, "D") = t1 = t2
    Next i

End Sub

Kod: 
Function SozcukSrl(Txt)

  Dim arr
  Dim strTemp As String
  Dim i As Integer
  Dim j As Integer
  Dim lngMin As Integer
  Dim lngMax As Integer

  Txt = Application.WorksheetFunction.Trim(Txt)
  Txt = UCase(Replace(Replace(Txt, "i", "İ"), "ı", "I"))

  ReDim arr(1 To Len(Txt))

  For i = 1 To Len(Txt)
    arr(i) = Mid(Txt, i, 1)
  Next i

  lngMin = LBound(arr)
  lngMax = UBound(arr)

  For i = lngMin To lngMax - 1
    For j = i + 1 To lngMax
      If arr(i) > arr(j) Then
        strTemp = arr(i)
        arr(i) = arr(j)
        arr(j) = strTemp
      End If
    Next j
  Next i
   
    Txt = ""
    For i = 1 To UBound(arr)
        Txt = Txt & arr(i)
    Next i
   
    SozcukSrl = Txt
   
End Function
Genişletmek için tıkla ...
Necdet Yeşertener üstadım, muhteşem bir kod daha. Elinize, aklınıza sağlık. KTF modunu da içeren mükemmel bir alternatifimiz daha oldu. Sağlıcakla kalın
 
Büyük/küçük dikkate almadan eşitliğini kontrol eder.
Kod: 
Sub Test()
    For i = 2 To Range("B" & Rows.Count).End(3).Row
        al1 = UCase(Replace(Replace(Range("B" & i).Value, "i", "İ"), "ı", "I"))
        al2 = UCase(Replace(Replace(Range("C" & i).Value, "i", "İ"), "ı", "I"))
        sonuc = "EŞİT DEĞİL"
        Do While al1 <> "" And Len(al1) = Len(al2)
            deg = Left(al1, 1)
            al1 = Replace(al1, deg, "")
            al2 = Replace(al2, deg, "")
            If al1 = al2 Then
                sonuc = "EŞİT"
                Exit Do
            End If
        Loop
        Cells(i, "E").Value = sonuc
    Next i
End Sub
 
baydeniro' Alıntı:
Necdet Yeşertener üstadım, muhteşem bir kod daha. Elinize, aklınıza sağlık. KTF modunu da içeren mükemmel bir alternatifimiz daha oldu. Sağlıcakla kalın
Genişletmek için tıkla ...

Merhaba,

Doğrudan KTF olarak ta kullanabilirsiniz.

Kod: 
=SozcukSrl(A1)=SozcukSrl(B1)

gibi.
 
veyselemre' Alıntı:
Büyük/küçük dikkate almadan eşitliğini kontrol eder.
Kod: 
Sub Test()
    For i = 2 To Range("B" & Rows.Count).End(3).Row
        al1 = UCase(Replace(Replace(Range("B" & i).Value, "i", "İ"), "ı", "I"))
        al2 = UCase(Replace(Replace(Range("C" & i).Value, "i", "İ"), "ı", "I"))
        sonuc = "EŞİT DEĞİL"
        Do While al1 <> "" And Len(al1) = Len(al2)
            deg = Left(al1, 1)
            al1 = Replace(al1, deg, "")
            al2 = Replace(al2, deg, "")
            If al1 = al2 Then
                sonuc = "EŞİT"
                Exit Do
            End If
        Loop
        Cells(i, "E").Value = sonuc
    Next i
End Sub
Genişletmek için tıkla ...
veyselemre üstadım, bu 2. kod da harika oldu. Gerektiğine birini, başka bir durumda diğerini kullanabiliriz. Emeğinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst