Return cells only containing certain letters

[oaj1977]

Here’s my scenario:

I have a list of words and a list of letters.
I want to return the words that contain letters from the list of letters and ONLY from the list of letters. For example:

WORDS: cog, bib, ab, back, cab
LETTERS: A, B, C
WORDS returned: ab, cab

Thoughts?

 

[Rick Rothstein]

Here is another way to write the Allow function (call it the same way you call Joe's version....

Function Allow(Word As String, Lett As Variant) As String
  Dim Vallow As String
  Vallow = Join(Application.Transpose(Lett), "")
  If Evaluate(Replace("SUM(0+ISNUMBER(SEARCH(MID(""@"",ROW(1:" & Len(Word) & "),1),""" & Vallow & """)))=LEN(""@"")", "@", Word)) Then Allow = Word
End Function

 

[Rick Rothstein]

Here is another way to write the Allow function (call it the same way you call Joe's version....

Function Allow(Word As String, Lett As Variant) As String
  Dim Vallow As String
  Vallow = Join(Application.Transpose(Lett), "")
  If Evaluate(Replace("SUM(0+ISNUMBER(SEARCH(MID(""@"",ROW($1:$4),1),""" & Vallow & """)))=LEN(""@"")", "@", Word)) Then Allow = Word
End Function

Actually, we can write this as a one-liner...

Function Allow(Word As String, Lett As Variant) As String
  If Evaluate(Replace("SUM(0+ISNUMBER(SEARCH(MID(""@"",ROW(1:" & Len(Word) & "),1),""" & Join(Application.Transpose(Lett), "") & """)))=LEN(""@"")", "@", Word)) Then Allow = Word
End Function

 

[Peter_SSs]

here it is as a table and also attached a screenshot...

Always best to include the expected results so that we can be sure of what they are and where you want them.
I am imagining that you would want the results in a compressed list like below and with tens of thousands of words I think a UDF might be a bit lethargic so you could see if this is any use.
You may have to amend this code to match your layout as I have assumed the words are in column A starting in row 2 and the letters are in column D starting in row 1.

Sub Get_Allowed()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  Set RX = CreateObject("VBScript.RegExp")
  RX.IgnoreCase = True
  RX.Pattern = "[^" & Join(Application.Transpose(Range("D1", Range("D" & Rows.Count).End(xlUp))), "") & "]"
  For i = 1 To UBound(a)
    If Not RX.test(a(i, 1)) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
  Next i
  Range("B2").Resize(k).Value = b
End Sub

Results:

oaj1977.xlsm
	A	B	C	D
1	Words	Allowed	Letters:	g
2	aahs	adad		i
3	aals	adai		e
4	aani	adda		l
5	aaru	agad		a
6	abac	agag		d
7	abay	agal
8	abas	aged
9	abba	agee
10	abbe	agla
11	abby	aide
12	abbr	aiel
13	abed
14	abey
15	abel
16	abet
17	abib
18	abie
19	abye
20	abir
Sheet2

 

[oaj1977]

Grrr - I'm getting a 429 Run-time error - ActiveX component can't create object. Debug is pointing to the line: Set RX=...

 

[Rick Rothstein]

I believe that is because you are using a Mac... I don't think the RegExp script language is not available for Macs. Did any of the other suggestions work for you?

 

[Peter_SSs]

Yes, sorry, I had read that you were using a Mac but forgot when deciding to use RegExp.
Here is an alternative to produce the list as in column B of my post 13 screen shot.

Sub Get_Allowed_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  Dim sLike As String
  
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
 
  s = "*[!" & Join(Application.Transpose(Range("D1", Range("D" & Rows.Count).End(xlUp))), "") & "]*"
  For i = 1 To UBound(a)
    If Not a(i, 1) Like sLike Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
  Next i
  Range("B2").Resize(k).Value = b
End Sub

 

[oaj1977]

Yes, sorry, I had read that you were using a Mac but forgot when deciding to use RegExp.
Here is an alternative to produce the list as in column B of my post 13 screen shot.

Sub Get_Allowed_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  Dim sLike As String
 
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)

  s = "*[!" & Join(Application.Transpose(Range("D1", Range("D" & Rows.Count).End(xlUp))), "") & "]*"
  For i = 1 To UBound(a)
    If Not a(i, 1) Like sLike Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
  Next i
  Range("B2").Resize(k).Value = b
End Sub

It runs, but it seems to be returning all words that contain any of the letters. It should only return words that contain ONLY those letters and not any others. The logic in the If/Then script seems to count words that contain any of the letters.

 

[Rick Rothstein]

The question I asked in Message #15 is still pending... "Did any of the other suggestions work for you?"

 

[oaj1977]

Yes - I got one of the other suggestions to work -- thanks, everyone!

 

[JoeMo]

Yes - I got one of the other suggestions to work -- thanks, everyone!

You are welcome - glad we could help.