In sheet1 column A, there are a lot of words of search for
In cell C1 I would type some letters to search for in these list in column A
If I type in cell C1 the letters "ACT" then I need to list all the words that contains these letters so the results would be [ACT - CAT - AT - ...]
The rule is to make sure the word has all the letters in "ACT"
If I typed in cell C1 the letters "ACT?". The question mark means any other character so the results should be as the following [ACT - CAT - AT - ACTS - CAST - ATOC ... and so on]
Amazing. Thank you so much
One remark when typing "ACT" I got an extra letter in results such as "ACTS" why?
When not using the question mark then I don't need to get extra letters so "ACTS", "ATOC" ... are not acceptable results. These words are acceptable when using the question mark only
Type two words in column A. eg "AT" and "CA"
then in cell c1 type "ACT?" and run your macro
These two words "AT" and "CA" are not included. Is it probable to include them too in the results?
I am so so sorry. Try typing the word "ZOOT" in column A and type "ACT?" in cell A1
When running the code, this word comes with results!!!
The question mark means only one unknown character so "ZOOT" is incorrect in that case as it has the letter "T" and that is OK but also has "O" & "O" & "Z" (and only one unknown character is acceptable)
In "AG" the letter "A" is in the searched letters and the letter "G" for the question mark
In "TO" the letter "T" is in the searched letters and the letter "O" for the question mark
In "ZA" the letter "A" is in the searched letters and the letter "Z" for the question mark
In "TI" the letter "T" is in the searched letters and the letter "I" for the question mark
Retired in Ipswich, Suffolk, but grew up in Sawley, Derbyshire (England)
MS-Off Ver
MS 365 Subscription Insider Beta Channel v. 2404 (Windows 11 22H2 64-bit)
Posts
80,779
Re: Search and extract all the possible letters
This thread is marked as solved, and clearly is not.
Ali Enthusiastic self-taught user of MS Excel who's always learning! Don't forget to say "thank you" in your thread to anyone who has offered you help.
You can reward them by clicking on * Add Reputation below their user name on the left, if you wish. Forum Rules (updated August 2023): please read them here.
one remark as for the last working and perfect code
If I put a word "ANTA" and typed the letters in c1 "ACT?", all the results are well and acceptable except the word "ANTA". This word is not acceptable in that case
the letter "A" is ok and the letter "T" is ok
the question mark is for either the letter "A" or "N" not both of them
I mean that the letter in the searched letters is used for just once not twice so if the letter "A" is typed in the searched letters once, so it would be used once. If typed twice, it would be used twice
e.g
if there is a word "COCA" in column A and I typed "ACC?" so "COCA" is acceptable as the letter "C" twice in the searched letters and "A" is already there and the letter "O" is for the question mark
This code trigger any change in column A or cell C1.
Righ click on tab's name, view code then paste below code into editting window:
Maybe, try:
PHP Code:
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lr&, i&, j&, m&, c&, k&, rng, Scell As String, Lcell As String, s As String, arr(1 To 10000, 1 To 1) If Not Intersect(Target, Union(Columns(1), Range("C1"))) Is Nothing Then lr = Cells(Rows.Count, "A").End(xlUp).Row rng = Range("A1:A" & lr).Value Scell = Range("C1").Value ' search cell For i = 1 To lr Lcell = rng(i, 1) ' Looking range c = Len(Lcell) - IIf(InStr(1, Scell, "?"), 1, 0) If Len(Lcell) <= Len(Scell) Then For j = 1 To Len(Lcell) For m = 1 To Len(Scell) If Mid(Lcell, j, 1) = Mid(IIf(s = "", Scell, s), m, 1) Then c = c - 1 s = Replace(IIf(s = "", Scell, s), Mid(Lcell, j, 1), "", 1, 1) End If Next Next If c < 1 Then k = k + 1 arr(k, 1) = Lcell End If End If s = "" Next Range("B2:B10000").ClearContents If k > 0 Then Range("B2").Resize(k, 1).Value = arr End If End Sub
@bebo
The code is really amazing. Can you add something if possible?
If the searched letters have the question mark then I need to add between brackets the letter that substituted the question mark
e.g.
the searched letters "AACT?" and in results the word "ANTA". I need the result to be like that
In column A type the word "RHOTIC" and in c1 type these letters "ETIRCOR" (without the question mark)
You will notice the word comes with results although it has no "H" letter !!?
The question in simple words
check each word letters opposite the searched letters and make sure all the letters are already there
the words "ACTS" & "CATS" is acceptable if the searched letters was "ACT?"
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lr&, i&, j&, m&, c&, k&, rng, Scell As String, Lcell, ex As String, arr(1 To 10000, 1 To 1) Dim dic As Object, key If Not Intersect(Target, Union(Columns(1), Range("C1"))) Is Nothing Then lr = Cells(Rows.Count, "A").End(xlUp).Row rng = Range("A1:B" & lr).Value Scell = Range("C1").Value ' search cell For i = 1 To lr Set dic = CreateObject("Scripting.Dictionary") For j = 1 To Len(Scell) If Not dic.exists(Mid(Scell, j, 1)) Then dic.Add Mid(Scell, j, 1), 1 Else dic(Mid(Scell, j, 1)) = dic(Mid(Scell, j, 1)) + 1 End If Next Lcell = rng(i, 1) ' Looking range If Len(Lcell) <= Len(Scell) Then ex = "" For j = 1 To Len(Lcell) c = 0 For Each key In dic.keys If Mid(Lcell, j, 1) = key Then c = 1 Select Case dic(key) Case Is > 0 dic(key) = dic(key) - 1 Case Else ex = ex & Mid(Lcell, j, 1) End Select End If Next If c = 0 Then ex = ex & Mid(Lcell, j, 1) Next If ex = "" Or (Len(ex) = 1 And Right(Scell, 1) = "?") Then k = k + 1 arr(k, 1) = Lcell & IIf(ex = "", "", " [" & ex & "]") End If End If Set dic = Nothing Next Range("B2:B10000").ClearContents If k > 0 Then Range("B2").Resize(k, 1).Value = arr End If End Sub
With 80,000 rows, a dictionary is created then removed ... x 80000 times
Definietly its not a proper choice.
Does it annoy too much, if I employed few rows-columns in the right as helper columns (for ex, range E1:P3), to avoid dictionary life cycle loop? They can be deleted after run. And make sure they are availlable.
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lr&, i&, j&, m&, c&, k&, n&, rng, Scell As String, Lcell, ex As String, arr(1 To 10000, 1 To 1), arr1, sArr(1 To 100, 1 To 2) Dim dic As Object, key If Not Intersect(Target, Union(Columns(1), Range("C1"))) Is Nothing Then lr = Cells(Rows.Count, "A").End(xlUp).Row rng = Range("A1:B" & lr).Value Scell = Range("C1").Value ' search cell Set dic = CreateObject("Scripting.Dictionary") For j = 1 To Len(Scell) If Not dic.exists(Mid(Scell, j, 1)) Then dic.Add Mid(Scell, j, 1), 1 k = k + 1: sArr(k, 1) = Mid(Scell, j, 1): sArr(k, 2) = 1 Else dic(Mid(Scell, j, 1)) = dic(Mid(Scell, j, 1)) + 1 For i = 1 To k If sArr(k, 1) = Mid(Scell, j, 1) Then sArr(k, 2) = dic(Mid(Scell, j, 1)) Next End If Next For i = 1 To lr arr1 = sArr Lcell = rng(i, 1) ' Looking range If Len(Lcell) <= Len(Scell) And Lcell <> "" Then ex = "" For j = 1 To Len(Lcell) c = 0 For m = 1 To k If Mid(Lcell, j, 1) = arr1(m, 1) Then c = 1 Select Case arr1(m, 2) Case Is > 0 arr1(m, 2) = arr1(m, 2) - 1 Case Else ex = ex & Mid(Lcell, j, 1) End Select End If Next If c = 0 Then ex = ex & Mid(Lcell, j, 1) Next If ex = "" Or (Len(ex) = 1 And Right(Scell, 1) = "?") Then n = n + 1 arr(n, 1) = Lcell & IIf(ex = "", "", " [" & ex & "]") End If End If Next Range("B2:B10000").ClearContents If n > 0 Then Range("B2").Resize(n, 1).Value = arr End If End Sub
In this solution i'm just creating a 2nd column of the values in ColA.
I then just do a find and replace on each letter e.g. "A","C","T". ... replacing with ""
Then go back to each cell in copied column to see how much of a string is left. If 1 letter or less then the word in column A meets the criteria.
In other words I'm not parsing each word in each cell... just parsing the word in C1
LinkBack URL
About LinkBacks
Register To Reply
Originally Posted by KingTamo
Bookmarks