Unscramble word using data from spreadsheet. 2

[Zappd]

Hello,

How do I unscramble a word using data from the spreadsheet for words that match?
I only want to search the words on the spreadsheet, not an entire dictionary.
The columns are A to E and each has a header.
Word length will be 3 to 7 letters.
As an example if seu was searched it would return something like:
use
sue
sued
sues
ruse
used
user
uses

Tried using examples for these threads and was unable to get anything to work.
thread707-1458309: Word Descrambler Word Descrambler
thread222-1195039: Word puzzle / unscramble Word puzzle / unscramble

Attached is the spreadsheet I'm using.

Please let me if there are any questions.
Zappd

 

[mikrom]

It met the initial requirements which OP posted on 13 Nov 21 22:23, I used the pattern [seu]

Based on the post by OP on 19 Nov 21 22:31, it seems that following patterns could be used:
for column A: [ab]{3}
for column B: [ab]{4}
...
for column E: [ab]{7}

I changed the subroutine, that it now iterates column wise and for every column uses pattern mentioned above

[COLOR=#804040][b]Sub[/b][/color] search_cells[COLOR=#804040][b]()[/b][/color]
    [COLOR=#804040][b]Dim[/b][/color] cell_range [COLOR=#804040][b]As[/b][/color] Range[COLOR=#804040][b],[/b][/color] cell [COLOR=#804040][b]As[/b][/color] Range
    DBG_INFO [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]False[/color]
    [COLOR=#804040][b]Set[/b][/color] cell_range [COLOR=#804040][b]=[/b][/color] Range[COLOR=#804040][b]([/b][/color][COLOR=#ff00ff]"A1:E20"[/color][COLOR=#804040][b])[/b][/color]
    chars [COLOR=#804040][b]=[/b][/color] [COLOR=#008080]InputBox[/color][COLOR=#804040][b]([/b][/color][COLOR=#ff00ff]"Enter characters to search for"[/color][COLOR=#804040][b])[/b][/color]
   [COLOR=#0000ff] 'pattern for one character[/color]
    pattern_one [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]"["[/color] [COLOR=#804040][b]+[/b][/color] chars [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"]"[/color]
   [COLOR=#0000ff] 'start with 3 char pattern[/color]
    k [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]3[/color]
    [COLOR=#804040][b]For[/b][/color] [COLOR=#804040][b]Each[/b][/color] Column [COLOR=#804040][b]In[/b][/color] cell_range[COLOR=#804040][b].[/b][/color]Columns
        pattern_string [COLOR=#804040][b]=[/b][/color] pattern_one [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"{"[/color] [COLOR=#804040][b]+[/b][/color] [COLOR=#008080]CStr[/color][COLOR=#804040][b]([/b][/color]k[COLOR=#804040][b])[/b][/color] [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"}"[/color]
        [COLOR=#804040][b]If[/b][/color] DBG_INFO [COLOR=#804040][b]Then[/b][/color] [COLOR=#008080]MsgBox[/color] [COLOR=#ff00ff]"Pattern String : """[/color] [COLOR=#804040][b]+[/b][/color] pattern_string [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]""""[/color]
        [COLOR=#804040][b]For[/b][/color] [COLOR=#804040][b]Each[/b][/color] cell [COLOR=#804040][b]In[/b][/color] Column[COLOR=#804040][b].[/b][/color]Cells
            [COLOR=#804040][b]If[/b][/color] regex_test[COLOR=#804040][b]([/b][/color]cell[COLOR=#804040][b],[/b][/color] pattern_string[COLOR=#804040][b])[/b][/color] [COLOR=#804040][b]Then[/b][/color]
                cell[COLOR=#804040][b].[/b][/color]Font[COLOR=#804040][b].[/b][/color]Color [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]vbRed[/color]
            [COLOR=#804040][b]Else[/b][/color]
                cell[COLOR=#804040][b].[/b][/color]Font[COLOR=#804040][b].[/b][/color]Color [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]vbBlack[/color]
            [COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]If[/b][/color]
        [COLOR=#804040][b]Next[/b][/color] cell
        k [COLOR=#804040][b]=[/b][/color] k [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]1[/color]
    [COLOR=#804040][b]Next[/b][/color] Column
[COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]Sub[/b][/color]

The result seems to meet the requirement posted by OP on 19 Nov 21 22:31:

 

[strongm]

>It met the initial requirements which OP posted on 13 Nov 21 22:23, I used the pattern [seu]

Well, no, it didn't. Your own posted screenshot shows it seu matching sql, for example. In fact what it actually does is match ANY word that contains at least one of the letters in the word being compared,(i.e any word with at least an 's' or an 'e' or a 'u' will be matched, which is definitely what the OP asked for (but explains why sql gets matched)

Your second version, if I still use 'sue', fails to match sued or sausage.

I'm a big fan of regular expressions, and have been banging a drum for them on this site for at least 15 years. And I have no doubt there is a regex solution to this - just not sure it is a simple one.

OP confirmed back on 18th Nov that their requirements were:

If the word being tested is shorter than search string, then match if all letter in word being tested are in the search string
If word being tested is same length as search string, then match if word is exact anagram of search string
If word being tested is longer than search string, then match if all letters in search string are in word being tested
Character order and proximity are not evaluated

 

[mikrom]

> If word being tested is longer than search string, then match if all letters in search string are in word being tested

Then if we have the search string aabb, all it's letters are in the word xabybaz, which is longer than search string.

.. But on 19 Nov 21 OP wrote:
"It would not find xabybaz as in your example because it contains letters other than a and b AND it's more than four letters in length"

Apart from that, my concern wasn't to provide an exact solution to the problem of OP, just to point out that the regular expressions are a way to go.

 

[Zappd]

Hope this helps and not hinder.
Here is the code I'm using.
The search is from strongm post from 18 Nov 21 11:12.

ThisWorkbook

    frmSearch.Show vbModeless
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Call condFormat
End Sub

Module1

Option Explicit
Sub Start()
    frmSearch.Show vbModeless
End Sub

Public Sub AutoFit()
    Range("A:E").EntireColumn.AutoFit
    Range("A:A").EntireRow.AutoFit
    Range("A2").Select
End Sub
Sub Sort()
    Columns("A:A").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    Columns("B:B").Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    Columns("C:C").Select
    Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    Columns("D:D").Select
    Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    Columns("E:E").Select
    Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
Call AutoFit
End Sub
Sub condFormat()
''check the number of letters in cell and turns red if number not eqaul to
    Dim rg, rg2, rg3, rg4, rg5 As Range
    Dim cond As FormatCondition, cond2 As FormatCondition, cond3 As FormatCondition, cond4 As FormatCondition, cond5 As FormatCondition
    Set rg = Range("A2", Range("A2").End(xlDown))
    Set rg2 = Range("B2", Range("B2").End(xlDown))
    Set rg3 = Range("C2", Range("C2").End(xlDown))
    Set rg4 = Range("D2", Range("D2").End(xlDown))
    Set rg5 = Range("E2", Range("E2").End(xlDown))
    
    Application.ScreenUpdating = False
    'clear any existing conditional formatting
    rg.FormatConditions.Delete
    rg2.FormatConditions.Delete
    rg3.FormatConditions.Delete
    rg4.FormatConditions.Delete
    rg5.FormatConditions.Delete
    
    'define the rule for each conditional format
    '3 letters
    Set cond = rg.FormatConditions.Add(xlExpression, xlNotEqual, Formula1:="=LEN(A2)=3")
    Set cond = rg.FormatConditions.Add(xlNoBlanksCondition)
    '4 letters
    Set cond2 = rg2.FormatConditions.Add(xlExpression, xlNotEqual, Formula1:="=LEN(B2)=4")
    Set cond2 = rg2.FormatConditions.Add(xlNoBlanksCondition)
    '5 letters
    Set cond3 = rg3.FormatConditions.Add(xlExpression, xlNotEqual, Formula1:="=LEN(C2)=5")
    Set cond3 = rg3.FormatConditions.Add(xlNoBlanksCondition)
    '6 letters
    Set cond4 = rg4.FormatConditions.Add(xlExpression, xlNotEqual, Formula1:="=LEN(D2)=6")
    Set cond4 = rg4.FormatConditions.Add(xlNoBlanksCondition)
    '7 letters
    Set cond5 = rg5.FormatConditions.Add(xlExpression, xlNotEqual, Formula1:="=LEN(E2)=7")
    Set cond5 = rg5.FormatConditions.Add(xlNoBlanksCondition)
    
    'define the format applied for each conditional format
    With cond
    .Interior.Color = vbRed
    .Font.Color = vbBlack
    End With
    With cond2
    .Interior.Color = vbRed
    .Font.Color = vbBlack
    End With
    With cond3
    .Interior.Color = vbRed
    .Font.Color = vbBlack
    End With
    With cond4
    .Interior.Color = vbRed
    .Font.Color = vbBlack
    End With
    With cond5
    .Interior.Color = vbRed
    .Font.Color = vbBlack
    End With
    Application.ScreenUpdating = True
End Sub
' If the word being tested is shorter than search string, then match if all letter in word being tested are in the search string
' If word being tested is same length as search string, then match if word is exact anagram of search string
' If word being tested is longer than search string, then match if all letters in search string are in word being tested
' Character order and proximity are not evaluated
Public Function partmatch(ByVal strTest As String, ByVal strSearch As String) As Boolean
    Dim lp As Long
    Dim keep As Long
    keep = Len(strTest)
    If Len(strTest) > 0 And Len(strSearch) > 0 Then
        ' Remove any matching characters that are in the testing string.
        For lp = 1 To Len(strSearch)
            strTest = Replace(strTest, Mid$(strSearch, lp, 1), "", , 1)
        Next
        partmatch = (keep - Len(strSearch) = Len(strTest)) Or Len(strTest) = 0 ' did we match all the characters?
    End If
End Function

frmSearch code

Private Sub UserForm_Activate()
    Me.StartUpPosition = 0
    Me.Top = Application.Top + 25
    Me.Left = Application.Left + Application.Width - Me.Width - 400
    Call ComboBox
   
  End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Button Clicks
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub cmbCopyLetters_Click()
    Call CopyLetters
End Sub

Private Sub cmbPasteLetters_Click()
    Call PasteLetters
End Sub
Private Sub cmbAdd_Click()
    Call CheckEmptyAdd
End Sub
Private Sub cmbSort_Click()
    Call Sort
End Sub
Private Sub cmbExit_Click()
    Unload Me
End Sub
Private Sub cmbSearch_Click()
    Call CheckEmpty
End Sub
Private Sub cmbClear_Click()
    Call Clear
End Sub
Sub CopyLetters()
    Range("G1").Value = tbSearch.Text
End Sub
Sub PasteLetters()
    tbSearch.Text = Range("G1").Value
End Sub
Sub ComboBox()
        ''Populate ComboBox
    cmbLetters.Clear
    cmbLetters.AddItem "3 Letters"
    cmbLetters.AddItem "4 Letters"
    cmbLetters.AddItem "5 Letters"
    cmbLetters.AddItem "6 Letters"
    cmbLetters.AddItem "7 Letters"
    
    tbSearch.SetFocus
End Sub
'combobox actions
Private Sub cmbLetters_Change()
    '''combobox actions
    If Me.cmbLetters.Value = "3 Letters" Then
        Range("A2").Select
    ElseIf Me.cmbLetters.Value = "4 Letters" Then
        Range("B2").Select
    ElseIf Me.cmbLetters.Value = "5 Letters" Then
        Range("C2").Select
    ElseIf Me.cmbLetters.Value = "6 Letters" Then
        Range("D2").Select
    ElseIf Me.cmbLetters.Value = "7 Letters" Then
        Range("E2").Select
    End If
    
End Sub
Private Sub tbSearch_Enter()
    With Me.tbSearch
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub
Private Sub Search(myRange As Range)
    Dim cell As Variant
    Dim i As Long
    lstbxView.Clear
    For Each cell In myRange 'enumerating a range goes across, then down, so may want to sort results
        ' you could add additional conditions here,  if eg you wanted to filter out matches that are longer than the search word
        If partmatch(LCase(cell), LCase(tbSearch.Text)) Then lstbxView.AddItem cell
    
    Next
    Call lbSort
    Call B4add
    
End Sub
Sub lbSort()
   'Sorts ListBox List
    Dim i As Long
    Dim j As Long
    Dim temp As Variant
       
    With Me.lstbxView
        For j = 0 To lstbxView.ListCount - 2
            For i = 0 To lstbxView.ListCount - 2
                If .List(i) > .List(i + 1) Then
                    temp = .List(i)
                    .List(i) = .List(i + 1)
                    .List(i + 1) = temp
                End If
            Next i
        Next j
    End With
End Sub
Sub NotFound()
    lstbxView.AddItem "No Match Found"
    Call cmbLetters_Change
    cmbAdd.SetFocus
End Sub
Sub B4add()
    tbCount.Value = Len(tbSearch.Text)
    If tbCount.Value = "3" Then Me.cmbLetters.Value = "3 Letters"
    If tbCount.Value = "4" Then Me.cmbLetters.Value = "4 Letters"
    If tbCount.Value = "5" Then Me.cmbLetters.Value = "5 Letters"
    If tbCount.Value = "6" Then Me.cmbLetters.Value = "6 Letters"
    If tbCount.Value = "7" Then Me.cmbLetters.Value = "7 Letters"
    tbAdd.Text = tbSearch.Text
    
    tbSearch.SetFocus
End Sub
Sub Add()
        Application.ScreenUpdating = False
    Do
        If IsEmpty(ActiveCell) = False Then
            ActiveCell.Offset(1, 0).Select
        End If
    Loop Until IsEmpty(ActiveCell) = True
            ActiveCell.Value = Trim(tbAdd)
        Call Sort
    Application.ScreenUpdating = True
    
End Sub
Sub tbadd_Change()
    tbCount.Value = Len(tbAdd.Text)
    If tbCount.Value = "3" Then Me.cmbLetters.Value = "3 Letters"
    If tbCount.Value = "4" Then Me.cmbLetters.Value = "4 Letters"
    If tbCount.Value = "5" Then Me.cmbLetters.Value = "5 Letters"
    If tbCount.Value = "6" Then Me.cmbLetters.Value = "6 Letters"
    If tbCount.Value = "7" Then Me.cmbLetters.Value = "7 Letters"
End Sub

Private Sub lstbxView_Click()
    'Dim StringSheet As String
    'Dim StringAddress As String
    
     '   StringSheet = lstbxView.List(lstbxView.ListIndex, 1)
     '   StringAddress = lstbxView.List(lstbxView.ListIndex, 2)
    
    'If StringAddress <> "" Then
    '    Worksheets(StringSheet).Activate
    '    Range(StringAddress).Activate
    'End If
    Call MsgBox(lstbxView.List(lstbxView.ListIndex))
    
    
End Sub
Private Sub CheckEmptyAdd()
    If Me.tbAdd.Value = vbNullString Then
        MsgBox "Cannot be blank !", vbExclamation, "Alert"
        tbAdd.SetFocus
    Else
        Call Add
    End If
End Sub
Private Sub CheckEmpty()
    If Me.tbSearch.Value = vbNullString Then
        MsgBox "Cannot be blank !", vbExclamation, "Alert"
        tbSearch.SetFocus
    Else
        Search Range("A2:E2500")
    End If
End Sub
Sub Clear()
    tbCount = ""
    tbAdd = ""
    lstbxView.Clear
    Call ComboBox
End Sub

It should only find words with three to six letters, but it still gets seven letter words.
Also tried messing with the sort but was unable to get it to do what I was wanting.
Want it alphabetically then by size(length) but could only get it alphabetically.
Hopefully this clears things up a bit.

 

[mikrom]

Hi Zappd,
And what about the 6-letter word "babble"? It's right that it was not selected because it doesn't exactly match the word "dabble" ?
Can you enter only strings which length is greater or equal 3 ? Or if not, what should then happen when your string length is less than 3, for example when you instead of "dabble" enter only "da" ?

 

[mikrom]

I modified the subroutine

[COLOR=#804040][b]Sub[/b][/color] search_cells[COLOR=#804040][b]()[/b][/color]
    [COLOR=#804040][b]Dim[/b][/color] cell_range [COLOR=#804040][b]As[/b][/color] Range[COLOR=#804040][b],[/b][/color] cell [COLOR=#804040][b]As[/b][/color] Range
    DBG_INFO [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]False[/color]
    [COLOR=#804040][b]Set[/b][/color] cell_range [COLOR=#804040][b]=[/b][/color] Range[COLOR=#804040][b]([/b][/color][COLOR=#ff00ff]"A2:E20"[/color][COLOR=#804040][b])[/b][/color]
    chars [COLOR=#804040][b]=[/b][/color] [COLOR=#008080]InputBox[/color][COLOR=#804040][b]([/b][/color][COLOR=#ff00ff]"Enter characters to search for"[/color][COLOR=#804040][b])[/b][/color]
    n [COLOR=#804040][b]=[/b][/color] [COLOR=#804040][b]Len[/b][/color][COLOR=#804040][b]([/b][/color]chars[COLOR=#804040][b])[/b][/color]
   [COLOR=#0000ff] 'pattern for one character[/color]
    pattern_one [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]"["[/color] [COLOR=#804040][b]+[/b][/color] chars [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"]"[/color]
   [COLOR=#0000ff] 'start searching with 3 char pattern[/color]
    k [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]3[/color]
    [COLOR=#804040][b]If[/b][/color] k [COLOR=#804040][b]>[/b][/color] n [COLOR=#804040][b]Then[/b][/color]
        [COLOR=#804040][b]If[/b][/color] DBG_INFO [COLOR=#804040][b]Then[/b][/color] [COLOR=#008080]MsgBox[/color] [COLOR=#ff00ff]"Exiting subroutine, because length of the given string < 3"[/color]
        [COLOR=#804040][b]Exit[/b][/color] [COLOR=#804040][b]Sub[/b][/color]
    [COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]If[/b][/color]
    [COLOR=#804040][b]For[/b][/color] [COLOR=#804040][b]Each[/b][/color] Column [COLOR=#804040][b]In[/b][/color] cell_range[COLOR=#804040][b].[/b][/color]Columns
        [COLOR=#804040][b]If[/b][/color] k [COLOR=#804040][b]<[/b][/color] n [COLOR=#804040][b]Then[/b][/color]
            pattern_string [COLOR=#804040][b]=[/b][/color] pattern_one [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"{"[/color] [COLOR=#804040][b]+[/b][/color] [COLOR=#008080]CStr[/color][COLOR=#804040][b]([/b][/color]k[COLOR=#804040][b])[/b][/color] [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]"}"[/color]
        [COLOR=#804040][b]ElseIf[/b][/color] k [COLOR=#804040][b]=[/b][/color] n [COLOR=#804040][b]Then[/b][/color]
            pattern_string [COLOR=#804040][b]=[/b][/color] chars
        [COLOR=#804040][b]Else[/b][/color]
            [COLOR=#804040][b]If[/b][/color] DBG_INFO [COLOR=#804040][b]Then[/b][/color] [COLOR=#008080]MsgBox[/color] [COLOR=#ff00ff]"Maximum words length reached. Processing end."[/color]
            [COLOR=#804040][b]Exit[/b][/color] [COLOR=#804040][b]For[/b][/color]
        [COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]If[/b][/color]
        [COLOR=#804040][b]If[/b][/color] DBG_INFO [COLOR=#804040][b]Then[/b][/color] [COLOR=#008080]MsgBox[/color] [COLOR=#ff00ff]"Pattern String : """[/color] [COLOR=#804040][b]+[/b][/color] pattern_string [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]""""[/color]
        [COLOR=#804040][b]For[/b][/color] [COLOR=#804040][b]Each[/b][/color] cell [COLOR=#804040][b]In[/b][/color] Column[COLOR=#804040][b].[/b][/color]Cells
            [COLOR=#804040][b]If[/b][/color] regex_test[COLOR=#804040][b]([/b][/color]cell[COLOR=#804040][b],[/b][/color] pattern_string[COLOR=#804040][b])[/b][/color] [COLOR=#804040][b]Then[/b][/color]
                cell[COLOR=#804040][b].[/b][/color]Font[COLOR=#804040][b].[/b][/color]Color [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]vbRed[/color]
            [COLOR=#804040][b]Else[/b][/color]
                cell[COLOR=#804040][b].[/b][/color]Font[COLOR=#804040][b].[/b][/color]Color [COLOR=#804040][b]=[/b][/color] [COLOR=#ff00ff]vbBlack[/color]
            [COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]If[/b][/color]
        [COLOR=#804040][b]Next[/b][/color] cell
        k [COLOR=#804040][b]=[/b][/color] k [COLOR=#804040][b]+[/b][/color] [COLOR=#ff00ff]1[/color]
    [COLOR=#804040][b]Next[/b][/color] Column
[COLOR=#804040][b]End[/b][/color] [COLOR=#804040][b]Sub[/b][/color]

Now after entering "dabble" it searches only words with length 3 until length 6 with the following results

 

[strongm]

it'll also match, just as a small sample of a fairly large number of incorrect matches it can make:

bee
eel
dead
deed
dell
addle
babab
bbbbb
bbbbbb
daaaaa
abbleb

And it won't find exact anagrams of the search word, just matches of the search word itself (feed it abbled instead of dabble and it will not find dabble ...)

Now all of these can be fixed up, of course. But the effort required seems counterproductive.

I'll repeat, I am a fan of regex (just checked, turns out I've been promoting it on tek-tips for over 20 years now; <gulp>), as it appears you are as well - but I think it is completely the wrong tool for this, and not a worthwhile alternative. Regexps are fairly rubbish with anagrams and subanagrams, and get worse if there are any repeated characters (and the VbScript regexp engine is missing one or two of the helper functions that eg .NET and Python regexp engines include such as lookbehinds and conditionals, that make it a bit easier)

 

[mikrom]

Hi strongm,

OK. At first I thought it would be easier with regexp, but now it's clear that it isn't.
Many thanks for the clarification.

 

[Andrzejek]

>Also tried messing with the sort but was unable to get it to do what I was wanting.

If that's the sort you are referring to, what does [highlight #FCE94F]j[/highlight] variable do

Sub lbSort()[green]
   'Sorts ListBox List[/green]
    Dim i As Long
    Dim [highlight #FCE94F]j[/highlight] As Long
    Dim temp As Variant
       
    With Me.lstbxView
        For [highlight #FCE94F]j[/highlight] = 0 To lstbxView.ListCount - 2
            For i = 0 To lstbxView.ListCount - 2
                If .List(i) > .List(i + 1) Then
                    temp = .List(i)
                    .List(i) = .List(i + 1)
                    .List(i + 1) = temp
                End If
            Next i
        Next [highlight #FCE94F]j[/highlight]
    End With
End Sub

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[mikrom]

Also tried messing with the sort but was unable to get it to do what I was wanting.
Want it alphabetically then by size(length) but could only get it alphabetically.

IMO normal sorting with string comparison does it, e.g.:

Sub bubble_sort(strings() As String)
    Dim Temp As String
    For i = LBound(strings) To UBound(strings) - 2
        For j = i + 1 To UBound(strings) - 1
            If strings(i) > strings(j) Then
                Temp = strings(j)
                strings(j) = strings(i)
                strings(i) = Temp
            End If
        Next j
    Next i
End Sub

Using it on this array

vba
foobar
baz
bar
spam
eggs
fop
excel
foo
d
c
b
a
expect
ex

i got this result, which is sorted alphabetically and then by length

a
b
bar
baz
c
d
eggs
ex
excel
expect
foo
foobar
fop
spam
vba

But if other sort is needed, for example first by length and then alphabetically - one can define other relation
greater-than and use it in the sorting:

Function greater_than(x As String, y As String) As Boolean
    'user-defined relation: greater-than
    If Len(x) < Len(y) Then
        greater_than = False
    ElseIf Len(x) > Len(y) Then
        greater_than = True
    Else 'i.e. when Len(x) = Len(y)
        greater_than = x > y
    End If
End Function

Sub bubble_sort(strings() As String)
    'sorting array of strings with user-defined relation greater-than
    Dim Temp As String
    For i = LBound(strings) To UBound(strings) - 2
        For j = i + 1 To UBound(strings) - 1
            If greater_than(strings(i), strings(j)) Then
                Temp = strings(j)
                strings(j) = strings(i)
                strings(i) = Temp
            End If
        Next j
    Next i
End Sub

then the sorted array from above would be:

a
b
c
d
ex
bar
baz
foo
fop
vba
eggs
spam
excel
expect
foobar

 

[Andrzejek]

I still feel that my solution from 19 Nov 21 18:39 is a valid one:
[ul]
[li]order letters in a search word in alphabetical order[/li]
[li]remove duplicate letters, if not needed[/li]
[li]order letters in a searched word in alphabetical order[/li]
[li]use InStr to determine is there is a match or not[/li]
[/ul]


---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Zappd]

Micron,
28 Nov 21 17:44
The search results added on date is exactly I'm trying to get.
Get a compile error sub or function not defined on regex_test when trying to run.
I get this message when trying to use regex

29 Nov 21 17:52
Added code to sort to Sub lbSort and get Compile error: Expected Array on thisline For i = LBound(strings) To UBound(strings) - 2 and it highlights the word LBound.

Sub lbSort()
   'Sorts ListBox List
    Dim i As Long
    Dim j As Long
    Dim Temp As String
    For i = LBound(strings) To UBound(strings) - 2
        For j = i + 1 To UBound(strings) - 1
            If greater_than(strings(i), strings(j)) Then
                Temp = strings(j)
                strings(j) = strings(i)
                strings(i) = Temp
            End If
        Next j
    Next i

End Sub
Function greater_than(x As String, y As String) As Boolean
    'user-defined relation: greater-than
    If Len(x) < Len(y) Then
        greater_than = False
    ElseIf Len(x) > Len(y) Then
        greater_than = True
    Else 'i.e. when Len(x) = Len(y)
        greater_than = x > y
    End If
End Function

28 Nov 21 16:41
It should not have found babble or any words using three b's such as babbled or blabbed. Not only do those have three b's, they are both over six letters in length.
D2 (babble) is only highlighted because it's a six letter word and that's what the code is supposed to do.
Yes, string length will be from three to seven letters in length. It will never search for two letter words.

Andrzejek,

The code from 19 Nov 21 18:39
It did not find ace, or arc in ecra

Sorry if I missed any questions.

 

[mikrom]

Get a compile error sub or function not defined on regex_test when trying to run.

Have you enabled regex in Developer/Visual Basic/Tools/References ?

 

[Andrzejek]

The code from 19 Nov 21 18:39
It did not find ace, or arc in ecra

I am afraid you got it backwards (or did I get it backwards...?)
'ace' and 'arc' are words - among others - to evaluate.
'ecra' is the word you type
So, 'ecra' cannot be in 'ace' or 'arc', not enough letters in 'ace' or 'arc'

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[strongm]

Andy, think they are suggesting that your code fails this condition : If the word being tested is shorter than search string, then match if all letter in word being tested are in the search string

 

[Andrzejek]

That is why I did ask several times for complete requirements, but got repeat of previously stated 'partial', and sometimes conflicting, rules.
I am sure my code can be easily modified to accommodate 'missed' needs.

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Zappd]

Looks like some screenshots were removed so will try to explain without them to reference.
Micron
Post 28 Nov 21 17:44 had an example of a search that was removed that met the criteria.

On Sheet1 there are five columns containing words that will be searched, A to E.
A=3 letter words, B=4 letter words and so on until E which contains 7 letter words.
Three letter words are the smallest it will find, because that's what is in column A.
It can find up to seven letter words, because that's what is in column E.
It will ONLY find words that are in A to E.

There is a userform frmSearch that contains a textbox named tbSearch where the search criteria is entered.
There is a command button cmbSearch that will start code to search columns A to E.
The output from the search goes to a listbox lstbxView.
I would like the listbox sorted as in Micron post Post 29 Nov 21 17:52 the last example.

Example:
A Contains
ale
bab
lea
B Contains
able
bead
bale
C Contains
baled
blade
D Contains
babble
blades
dabble
E Contains
blabbled

If the search criteria is babdel it will find:
ale
bab
lea
able
bale
bead
baled
dabble

It will not find blades because there is no s in the search.
It will not find blabbled because it's seven letters long and because it contains three b's.
I would like for it to be listed in the listbox as in the example.

 

[strongm]

Assuming that columns A to E are each correctly alpha sorted, then the follwing miniscule modification to my code achieves what you describe. I had left this as an exercise for the reader, but we seem to be going around in circles ...

[blue]Option Explicit

[COLOR=green]' If the word being tested is shorter than search string, then match if all letter in word being tested are in the search string
' If word being tested is same length as search string, then match if word is exact anagram of search string
' If word being tested is longer than search string, then match if all letters in search string are in word being tested - but should not happen in this version
' Character order and proximity are not evaluated[/color]
Public Function partmatch(ByVal strTest As String, ByVal StrSearch As String) As Boolean
    Dim lp As Long
    Dim keep As Long
    keep = Len(strTest)
    If Len(strTest) > 0 And Len(StrSearch) > 0 Then
        [COLOR=green]' Remove any matching characters that are in the testinng string.[/color]
        For lp = 1 To Len(StrSearch)
            strTest = Replace(strTest, Mid$(StrSearch, lp, 1), "", , 1)
        Next
        partmatch = (keep - Len(StrSearch) = Len(strTest)) Or Len(strTest) = 0 [COLOR=green]' did we match all the characters?[/color]
    End If
End Function

Private Sub Search(myRange As Range)
    Dim cell As Variant
    Dim colm As Variant

    ListBox1.Clear
    
    [COLOR=green]' Iterate cells in each column (i.e down then across rather than previous across then down)[/color]
    For Each colm In myRange.Columns
        For Each cell In colm.Cells 
            If Len(cell) <= Len(TextBox1.Text) Then
                If partmatch(LCase(cell), LCase(TextBox1.Text)) Then ListBox1.AddItem cell
            End If
        Next
    Next
End Sub

Private Sub CommandButton1_Click()
    Search Range("A2:E624") [COLOR=green]' Your range may differ[/color]
End Sub[/blue]

 

[Zappd]

Excellent and thank you.