Verilen Heceden Hareketle Veri Tabanından Kelime Yazdırma

[farisakboga]

Ekli dosyada sayfa2'de kelime veritabanı var. Sayfa1'de A sütununda yazacağım hecenin devamı olan tüm kelimeleri veritabanından harf sayısına göre bulup aynı satıra yazdırabilecek bir makro yazılabilir mi? Anlatımım eksik olmuştur maksadıyla el ile birkaç örnek yazdım. Okumaya yeni geçmiş öğrencilerim için düşündüğüm bu çalışmada yardımcı olabilirseniz çok makbule geçecek. Teşekkür ederim.

 

[dEdE]

Sayfanın kod bölümüne yapıştırarak dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myArr() As Variant
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
        Set s1 = Sheets("Sayfa1")
        Set s2 = Sheets("Sayfa2")
        uz = Len(s1.Range("A1"))
    If uz <= 1 Then Exit Sub
        ss = s2.Cells(Rows.Count, "A").End(3).Row
        j = 0
       
    For i = 1 To ss
        If Left(s2.Cells(i, 1), uz) = s1.Range("A1") Then
        ReDim Preserve myArr(j + 1)
            myArr(j) = s2.Cells(i, 1)
            j = j + 1
        End If
    Next i
        sk = s1.Cells(1, Columns.Count).End(xlToLeft).Column
        Range(Cells(1, 2), Cells(1, sk)).ClearContents
        Range("B1").Resize(1, UBound(myArr) + 1) = myArr
        Cells.EntireColumn.AutoFit
End Sub

 

[farisakboga]

Sayfanın kod bölümüne yapıştırarak dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myArr() As Variant
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
        Set s1 = Sheets("Sayfa1")
        Set s2 = Sheets("Sayfa2")
        uz = Len(s1.Range("A1"))
    If uz <= 1 Then Exit Sub
        ss = s2.Cells(Rows.Count, "A").End(3).Row
        j = 0
      
    For i = 1 To ss
        If Left(s2.Cells(i, 1), uz) = s1.Range("A1") Then
        ReDim Preserve myArr(j + 1)
            myArr(j) = s2.Cells(i, 1)
            j = j + 1
        End If
    Next i
        sk = s1.Cells(1, Columns.Count).End(xlToLeft).Column
        Range(Cells(1, 2), Cells(1, sk)).ClearContents
        Range("B1").Resize(1, UBound(myArr) + 1) = myArr
        Cells.EntireColumn.AutoFit
End Sub

Makroyu eklemeye çalıştım ancak makro ismi istiyor. Yapamadım maalesef.

 

[dEdE]

A1 hücresine en az iki büyük harf yazıp enter'e basınız.

 

[Trilenium]

Alternatif olması açısından A1 satırına girdiğiniz kelimeyi bulduktan sonra alta yapıştırır.. Arama alanı A1 dir.

NOT: BÜYÜK HARFLE aranmalıdır

 

[farisakboga]

Alternatif olması açısından A1 satırına girdiğiniz kelimeyi bulduktan sonra alta yapıştırır.. Arama alanı A1 dir.

NOT: BÜYÜK HARFLE aranmalıdır

A1 hücresine en az iki büyük harf yazıp enter'e basınız.

Çok teşekkür ederim elinize emeğinize sağlık.

 

[farisakboga]

Alternatif olması açısından A1 satırına girdiğiniz kelimeyi bulduktan sonra alta yapıştırır.. Arama alanı A1 dir.

NOT: BÜYÜK HARFLE aranmalıdır

Size de çok teşekkür ederim. Sizin de elinize emeğinize sağlık. İkinizin de kodları gayet güzel çalışıyor.

 

[dEdE]

Merhaba,
Sayın Trilenium un kodlara ek yapması, dikkatimi çekti ve kodları yeniden düzenledim. Bunun için Sayın Trilenium a teşekkür ediyorum.
Aşağıdaki kodlar; Büyük/küçük harf ayırımı yapmaz, öncekine göre üç kattan fazla hızlı çalışır, dosyayı şişirmemek adına 20 satırdan fazla çoğaltmaya izin vermez.
Hızı görmek ve önceki kod ile karşılaştırmak için Timer ekledim. Normal kullanımda gerek olmadığını düşünüyorum. İlgili satırlar çıkarılabilir.
Yeni önerilerle daha da geliştirilebilir.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myArr() As Variant
    Dim Hücre As Range
myTime = Timer
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
        Set s1 = Sheets("Sayfa1")
        Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
    Range("A1:B1").Select
    For Each Hücre In Selection
        If Hücre <> Empty Then Hücre = Evaluate("=UPPER(""" & Hücre & """)")
    Next
        uz = Len(s1.Range("A1"))
        If uz <= 1 Then Exit Sub
        ss = s2.Cells(Rows.Count, "A").End(3).Row
        j = 0
        hcr = s1.Range("A1")
        myDizi = s2.Range("A1:A" & ss)
    For i = 1 To UBound(myDizi)
        If Left(myDizi(i, 1), uz) = hcr Then
            ReDim Preserve myArr(j + 1)
            myArr(j) = s2.Cells(i, 1)
            j = j + 1
        End If
    Next i
        Range("B1").Resize(1, UBound(myArr) + 1) = myArr
        Cells.EntireColumn.AutoFit
        Rows("1:1").Insert Shift:=xlDown
        s1.Range("A1").Select
        s1.Rows("21:21").ClearContents
Application.ScreenUpdating = True
MsgBox "Görev  tamamlandı." & vbCrLf & "İYİ YILLAR" & vbCrLf & "İşlem süresi ; " & _
    Format(Timer - myTime, "0.00") & " Saniye", vbInformation, "BİLGİ"
End Sub