Aynı harflerden oluşan kelimeleri bulma

ahmetozcan9211 · 3 Ocak 2019

bir excel dosyası oluşturdum. türkçedeki bütün 5 harfli kelimeleri içeriyor. yapmak istediğim şu bu listedeki aynı harflari içeren kelimeleri bulmak istiyorum. örnek veriyorum
exceli çalıştırıp kelimeleri bul dediğimde aynı harfteki kelimeleri bulmasını istiyorum mesela
Sıfır,fısır
anlam,alman... gibi bunu nasıl yapabilirim yardımcı olma şansınız var mı?

UluocakYasin · 3 Ocak 2019

Merhabalar,

Konuyu tam olarak anlamadım ama excel dosyanıza girip CTRL+F tuşuna basıp istediğiniz kelimeyi yazıp tümünü bul dediğinizde aradığınız kelimelerin hücrelerini size göstermektedir.

Saygılarımla

kulomer46 · 3 Ocak 2019

A Sütununda 5 Karakter Uzunluğunda Olan ve Yerleri Karışık Bile Olsa Aynı Karakterleri Barındıran Kelimeleri
Kendi Aralarında Gruplayan Program yüklü Dosya Ek' tedir.

Selamlar..

ahmetozcan9211 · 3 Ocak 2019

kulomer46' Alıntı:
A Sütununda 5 Karakter Uzunluğunda Olan ve Yerleri Karışık Bile Olsa Aynı Karakterleri Barındıran Kelimeleri Kendi Aralarında Gruplayan Program yüklü Dosya Ek' tedir.
Selamlar..

Dosyayı indiremiyorum altın üye olmalısınız diyor

kulomer46 · 3 Ocak 2019

ahmetozcan9211' Alıntı:
Dosyayı indiremiyorum altın üye olmalısınız diyor

O zaman kodları aşağıya yazıyorum.

Aşağıdaki kodları modul sayfasına akleyip çalıştırırsanız isteğinize uygun grup bilgileri B ve C sütunlarında listelenecektir.
Selamlar...

Sub A_Sütunundaki_Aynı_Karakterli_Kelimeleri_gruplandır()
'03.01.2019 08:48
Dim dizi()

Zaman = Timer

Columns(2).ClearContents
Columns(3).ClearContents
'Columns(4).ClearContents

timer1 = Timer
Do While Timer - timer1 < 0.3
Loop

sona = Cells(Rows.Count, 1).End(3).Row

ReDim dizi(sona, 6)

For i = 1 To Cells(Rows.Count, 1).End(3).Row

If Len(Trim(Cells(i, 1))) = 5 Then

dizi(i, 0) = LCase(Trim(Cells(i, 1)))
dizi(i, 1) = Mid(dizi(i, 0), 1, 1)
dizi(i, 2) = Mid(dizi(i, 0), 2, 1)
dizi(i, 3) = Mid(dizi(i, 0), 3, 1)
dizi(i, 4) = Mid(dizi(i, 0), 4, 1)
dizi(i, 5) = Mid(dizi(i, 0), 5, 1)

For k1 = 1 To 5
For k2 = 1 To 5

If dizi(i, k1) < dizi(i, k2) Then
bos1 = dizi(i, k1)
dizi(i, k1) = dizi(i, k2)
dizi(i, k2) = bos1
End If

Next
Next

For k3 = 1 To 5

dizi(i, 6) = dizi(i, 6) & dizi(i, k3)

Next

' Cells(i, 2) = dizi(i, 6)

Else

' Cells(i, 2) = " DİKKAT! : Yan Hücredeki değerin Karakter Uzunluğu 5 Karakter Değildir"

End If

Next
For ii = 1 To sona

grup1 = grup1 + 1
var1 = 0
sayyy1 = 0

For jj = ii + 1 To sona

If dizi(ii, 6) = dizi(jj, 6) And Cells(jj, 2) = "" And Len(dizi(ii, 6)) = 5 Then

var1 = 1
sayyy1 = sayyy1 + 1
Cells(ii, 2) = "Grup " & grup1
Cells(jj, 2) = "Grup " & grup1

If sayyy1 = 1 Then
Cells(grup1, 3) = Cells(ii, 1) & "." & Cells(jj, 1)
Else
Cells(grup1, 3) = Cells(grup1, 3) & "." & Cells(jj, 1)
End If
' MsgBox ii

End If

Next

If var1 = 0 Then grup1 = grup1 - 1

Next

Bitis = Chr(10) & "(İşlem Süresi : " & Format(Timer - Zaman, "00:00") & " dakika)"

If grup1 > 0 Then
MsgBox grup1 & " adet farklı grup tespit edildi" & Chr(10) & Chr(10) & "Gruplama Tamamlandı" & Bitis, , " Microsoft Excel - Mutluluk Sizinle Olsun"
Else
MsgBox "A Sütununda 5 Karakterli olup Aynı Karakterleri Barındıran hücreler bulunmamaktadır." & Chr(10) & Chr(10) & "Hiç Grup Oluşturulamadı", , " Microsoft Excel - Mutluluk Sizinle Olsun"
End If

End Sub

ahmetozcan9211 · 3 Ocak 2019

kulomer46' Alıntı:
O zaman kodları aşağıya yazıyorum.

Aşağıdaki kodları modul sayfasına akleyip çalıştırırsanız isteğinize uygun grup bilgileri B sütununda listelenecektir.
Selamlar...

Sub A_Sütunundaki_Aynı_Karakterli_Kelimeleri_gruplandır()
'03.01.2019 08:48
Dim dizi()

Columns(2).ClearContents
'Columns(3).ClearContents

timer1 = Timer
Do While Timer - timer1 < 0.3
Loop

sona = Cells(Rows.Count, 1).End(3).Row

ReDim dizi(sona, 6)

For i = 1 To Cells(Rows.Count, 1).End(3).Row

If Len(Trim(Cells(i, 1))) = 5 Then

dizi(i, 0) = LCase(Trim(Cells(i, 1)))
dizi(i, 1) = Mid(dizi(i, 0), 1, 1)
dizi(i, 2) = Mid(dizi(i, 0), 2, 1)
dizi(i, 3) = Mid(dizi(i, 0), 3, 1)
dizi(i, 4) = Mid(dizi(i, 0), 4, 1)
dizi(i, 5) = Mid(dizi(i, 0), 5, 1)

For k1 = 1 To 5
For k2 = 1 To 5

If dizi(i, k1) < dizi(i, k2) Then
bos1 = dizi(i, k1)
dizi(i, k1) = dizi(i, k2)
dizi(i, k2) = bos1
End If

Next
Next

For k3 = 1 To 5

dizi(i, 6) = dizi(i, 6) & dizi(i, k3)

Next

' Cells(i, 2) = dizi(i, 6)

Else

' Cells(i, 2) = " DİKKAT! : Yan Hücredeki değerin Karakter Uzunluğu 5 Karakter Değildir"

End If

Next
For ii = 1 To sona

grup1 = grup1 + 1
var1 = 0

For jj = ii + 1 To sona

If dizi(ii, 6) = dizi(jj, 6) And Cells(jj, 2) = "" And Len(dizi(ii, 6)) = 5 Then

var1 = 1
Cells(ii, 2) = "Grup " & grup1
Cells(jj, 2) = "Grup " & grup1
' MsgBox ii

End If

Next

If var1 = 0 Then grup1 = grup1 - 1

Next

If grup1 > 0 Then
MsgBox grup1 & " adet farklı grup tespit edildi" & Chr(10) & Chr(10) & "Gruplama Tamamlandı", , " Microsoft Excel - Mutluluk Sizinle Olsun"
Else
MsgBox "A Sütununda 5 Karakterli olup Aynı Karakterleri Barındıran hücreler bulunmamaktadır." & Chr(10) & Chr(10) & "Hiç Grup Oluşturulamadı", , " Microsoft Excel - Mutluluk Sizinle Olsun"
End If

End Sub

hocam cevabınız için teşekkürler. çalıştırdığımda kelimleri gruplandırıyor evet ancak bu şekilde kastetmemiştim. ingilizce kelimeden örnek vereyim size
ALERT.LATER.ALTER
ABETS.BEATS.BEAST
ANGEL.ANGLE.GLEAN
COATS.COAST.TACOS
RATES.STARE.TEARS

buradaki gibi aynı harflerden oluşan kelimeleri aralarına nokta koyarak yan yana yazmak istiyorum. eğer yardımcı olursanız benı cok mutlu edersiniz tekrar teşekkürler

leumruk · 3 Ocak 2019

Selamlar,
Hazırladığım örneği deneyiniz.

Kod:

Sub kelimebul2()
Zaman = Timer
Columns(3).ClearContents
sonsat = Cells(Rows.Count, 1).End(3).Row
'sonsat2 = Cells(Rows.Count, 2).End(3).Row
For i = 1 To sonsat
Aranan = Cells(i, 1)
For x = 1 To sonsat
UAranan = Len(Aranan)
klm = Cells(x, 1)
If UAranan = Len(Cells(x, 1)) Then
    For y = 1 To UAranan
        hrf = Mid(Aranan, y, 1)
        klm = WorksheetFunction.Substitute(klm, hrf, "", 1)
    Next
    If klm = "" Then
        mtn = mtn & "." & Cells(x, 1)
    End If
End If
Next
If Len(mtn) > 6 Then
If sat = "" Then sat = 1
say = WorksheetFunction.CountIf(Range("c1:c" & sat), mtn)
If say = 0 Then
sat = sat + 1
Cells(sat, 3) = mtn
End If
End If
mtn = ""
Next
Bitis = Chr(10) & "İşlemin tamamlanma süresi: " & Format(Timer - Zaman, "00:00") & " dakika"
MsgBox "İşlem tamamlandı." & Bitis, vbOKOnly, "l e u m r u k"
End Sub

kelime-bul dosyası

ahmetozcan9211 · 3 Ocak 2019

leumruk' Alıntı:

Selamlar,
Hazırladığım örneği deneyiniz.

Kod:

Sub kelimebul()
Zaman = Timer
Columns(3).ClearContents
sonsat = Cells(Rows.Count, 1).End(3).Row
sonsat2 = Cells(Rows.Count, 2).End(3).Row
For i = 1 To sonsat2
Aranan = Cells(i, 2)
For x = 1 To sonsat
UAranan = Len(Aranan)
klm = Cells(x, 1)
If UAranan = Len(Cells(x, 1)) Then
    For y = 1 To UAranan
        hrf = Mid(Aranan, y, 1)
        klm = WorksheetFunction.Substitute(klm, hrf, "", 1)
    Next
    If klm = "" Then
        mtn = mtn & "." & Cells(x, 1)
    End If
End If
Next
Cells(i, 3) = mtn
mtn = ""
Next
Bitis = Chr(10) & "İşlemin tamamlanma süresi: " & Format(Timer - Zaman, "00:00") & " dakika"
MsgBox "İşlem tamamlandı." & Bitis, vbOKOnly, "l e u m r u k"
End Sub

kelime-bul dosyası

hocam çalışmadı.

leumruk · 3 Ocak 2019

ahmetozcan9211' Alıntı:
hocam çalışmadı.

Çalışmadı kısmını biraz açabilirseniz yardımcı olmaya çalışayım.
Sonuç mu üretmedi? İstediğiniz sonucu mu alamadınız? Hata mı verdi? vs...

ahmetozcan9211 · 3 Ocak 2019

leumruk' Alıntı:
Çalışmadı kısmını biraz açabilirseniz yardımcı olmaya çalışayım.
Sonuç mu üretmedi? İstediğiniz sonucu mu alamadınız? Hata mı verdi? vs...

Sonuc üretmesi hocam. Şöyle yapalım. Excel dosyam bu https://docs.google.com/spreadsheets/d/1fHnPp8yntVLaStgvPQi7XwGerLiiK_XcVqKyaK0sFBw/edit?usp=drivesdk
Ben bu dosyadaki aynı harflerden oluşan kelimeleri bulmak istiyorum. Ve sonuçları aralarında nokta olarak birleşik olarak yazmak istiyorum
Kelime1.kelime2.kelime3 gibi

leumruk · 4 Ocak 2019

Üstteki mesaja 2. bir kodlama ekledim.

ahmetozcan9211 · 4 Ocak 2019

leumruk' Alıntı:
Üstteki mesaja 2. bir kodlama ekledim.

Yine aynı şekilde hocam. İşlem 0 sn tamamlandı diyor ancak hiç bir düzenleme vs yapmıyor sonuç vermiyor yani

Tevfik_Kursun · 4 Ocak 2019

Sayın ahmetozcan9211,
Her iki dosya da bu Dosyalar bağlantıda. Sanırım Kelime-bul_1 sizin istediğiniz gibi çalışıyor.
Kolay gelsin

kulomer46 · 4 Ocak 2019

Tevfik_Kursun' Alıntı:
Sayın ahmetozcan9211,
Her iki dosya da bu Dosyalar bağlantıda. Sanırım Kelime-bul_1 sizin istediğiniz gibi çalışıyor.
Kolay gelsin

Sayın Tevfik_Kursun arkadaşımızın emeğine sağlık.
Bende kendi dosyamın sizin isteğinize uygun son halini aşağıya ekledim.

Ve yukardaki #5 nolu mesajdada kodların son halini güncelledim.
Ek'li dosyayı indiremezseniz yukarda #5 nolu mesajdaki kodları kopyalayıp uygulayınız.
Selamlar...

veyselemre · 4 Ocak 2019

Kod:

Sub test()
    Columns(4).ClearContents
    dizi = (WorksheetFunction.Transpose(Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value))
    With CreateObject("Scripting.Dictionary")
        For i = LBound(dizi) To UBound(dizi)
            klm = parcalaSirala(dizi(i))
            If Not .exists(klm) Then
                .Item(klm) = dizi(i)
            Else
                .Item(klm) = .Item(klm) & "." & dizi(i)
            End If
        Next i
        For Each itm In .items
            If InStr(itm, ".") Then
                sat = sat + 1
                Cells(sat, 4) = itm
            End If
        Next
    End With
End Sub
Function parcalaSirala(ByVal kelime As String) As String
    ReDim a(Len(kelime))
    For i = 1 To Len(kelime)
        a(i) = Mid(kelime, i, 1)
    Next i
    For i = LBound(a) To UBound(a) - 1
        For ii = i + 1 To UBound(a)
            If StrComp(a(i), a(ii), vbTextCompare) = 1 Then
                ara = a(i)
                a(i) = a(ii)
                a(ii) = ara
            End If
        Next ii
    Next i
    parcalaSirala = Join(a, "")
End Function

ahmetozcan9211 · 4 Ocak 2019

Tevfik_Kursun' Alıntı:
Sayın ahmetozcan9211,
Her iki dosya da bu Dosyalar bağlantıda. Sanırım Kelime-bul_1 sizin istediğiniz gibi çalışıyor.
Kolay gelsin

cevabınız için çok teşekkürler. tam istediğim gibi çalışıyor hocam. yalnız kullanılan kelimeleri de listeden silmesini de istiyorum bunu nasıl yapabilirim?

bycakir · 4 Ocak 2019

bulmacaları macro ilemi çözeceksiniz

veyselemre · 4 Ocak 2019

ahmetozcan9211' Alıntı:
kullanılan kelimeleri de listeden silmesini de istiyorum bunu nasıl yapabilirim?

Kod:

Sub test()
    Columns(4).ClearContents
    dizi = WorksheetFunction.Transpose(Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value)
    Dim w(1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = LBound(dizi) To UBound(dizi)
            klm = parcalaSirala(dizi(i))
            If Not .exists(klm) Then
                w(1) = dizi(i)
                w(2) = i & ":" & i
                .Item(klm) = w
            Else
                y = .Item(klm)
                y(1) = y(1) & "." & dizi(i)
                y(2) = y(2) & "," & i & ":" & i
                .Item(klm) = y
            End If
        Next i
        For Each itm In .items
            If InStr(itm(1), ".") Then
                sat = sat + 1
                Cells(sat, 4) = itm(1)
                
                adr = itm(2)
                Intersect(Columns(1), Range(adr)).ClearContents
            End If
        Next
    End With
End Sub
Function parcalaSirala(ByVal kelime As String) As String
    ReDim a(Len(kelime))
    For i = 1 To Len(kelime)
        a(i) = Mid(kelime, i, 1)
    Next i
    For i = LBound(a) To UBound(a) - 1
        For ii = i + 1 To UBound(a)
            If StrComp(a(i), a(ii), vbTextCompare) = 1 Then
                ara = a(i)
                a(i) = a(ii)
                a(ii) = ara
            End If
        Next ii
    Next i
    parcalaSirala = Join(a, "")
End Function

Tevfik_Kursun · 4 Ocak 2019

Merhaba Sayın ahmetozcan9211,
Kulomer46 Hocanın dosyası da Dosyalar bağlantısında. Veyselemre Hocanınkini takip edeyim. Çalıştığında onu da aynı bağlantıya yerleştiririm.
kolay gelsin

Tevfik_Kursun · 4 Ocak 2019

Merhaba Veysel Hocam,
Bu noktada syntax error veriyor. Nedeni için bakar mısınız lütfen, arkadaşımıza yardımcı olalım.
Kolay gelsin

Aynı harflerden oluşan kelimeleri bulma

ahmetozcan9211

UluocakYasin

kulomer46

Ekli dosyalar

ahmetozcan9211

kulomer46

ahmetozcan9211

leumruk

Uzman

Ekli dosyalar

ahmetozcan9211

leumruk

Uzman

ahmetozcan9211

leumruk

Uzman

ahmetozcan9211

Tevfik_Kursun

Ekli dosyalar

kulomer46

Ekli dosyalar

veyselemre

Özel Üye

ahmetozcan9211

bycakir

veyselemre

Özel Üye

Tevfik_Kursun

Tevfik_Kursun

Ekli dosyalar