Adding in a character into a string to get different variations

[muchobrento]

Hi all. This is my first post, though I've used the site as a resource for many years.

I am trying to figure out every single variation of the word "football" by adding in a "." at different places, with the only change in the word being the position of the "." while also having no limit to the number of "." added.

For example:

1. f.ootball
2. fo.otball
3. foo.tball
4. ...
5. ...
6. f.o.ootball
7. f.oo.otball
8. f.oot.ball
9. ...
10. ...
11. f.o.o.t.b.a.l.l

Hopefully that is clear. Thanks in advance for the help!

 

[WarPigl3t]

I just created a macro like this a few days ago for someone else. I'm going to assume you know how to make macros because you have been using excel for years. So I'm not going to make the macro for you. I'll just give you ideas. Use the REPLACE function to get rid of the periods. Replace the periods of the string with "". That should fix most of your problems. Now it won't fix words that are just spelled wrong. Like your numbers 6 and 7 in your example table. You'll have to add code that counts how many errors are in the text. You can make it say that if there is only 1 error then consider it the same as football. Ill see if I can find the forum I put that code in so you can use it as a reference. I don't want to write it again. It was very confusing.

 

[WarPigl3t]

I Found the forum. The SOLVED thread is where you will find the code you need to consider your misspellings a match to football. http://www.mrexcel.com/forum/excel-questions/800913-comparing-2-sets-data-partial-match.html

 

[WarPigl3t]

I went out of my way to create some easy to use functions that are short so I can reuse them. Start by copying these functions into your VBA macros.

Function myTrimError(val, remCriteria)
   [COLOR=#008000] 'What this code does:  "val" is the cell with the value that needs to get inspected. _
    "remCriteria" is the criteria that needs to be removed.[/COLOR]
    output = Replace(val, remCriteria, "")
    myTrimError = output
End Function

Function myCompare1ErrorDifference(valOriginal, valCompare)
 [COLOR=#008000]   'What this code does:  "valOriginal" is the string to be evaluated. _
    "valCompare" is the correctly spelled string. _
    If "valOriginal" only has 1 character difference in error compared to "valCompare" _
    then it will consider it a match and display the value. _
    The function will also display the value if there are no errors. _
    The function will return blank if it finds more than 1 error.[/COLOR]
    
    valOLen = Len(valOriginal)
    valCLen = Len(valCompare)
    errorCounter = 0
    If valOLen > valCLen Then
        loopExit = valOLen
    Else
        loopExit = valCLen
    End If
    nxtChr = 1
    Do Until nxtChr > loopExit
        If Mid(valOriginal, nxtChr, 1) <> Mid(valCompare, nxtChr, 1) Then
            errorCounter = errorCounter + 1
            Exit Do
        End If
        nxtChr = nxtChr + 1
    Loop
    If errorCounter = 1 Then
        If Right(valOriginal, loopExit - nxtChr) = Right(valCompare, loopExit - nxtChr) Then
            myCompare1ErrorDifference = valCompare
            Exit Function
        Else
            myCompare1ErrorDifference = ""
        End If
    Else
        myCompare1ErrorDifference = valOriginal
    End If
End Function

You didn't label your table so I'll do it for you.

	A	B	C
1	f.o.o.t.b.b.a.l.l	football	=myCompare1ErrorDifference(myTrimError(A1,"."),B1)

<tbody>
</tbody>

 

[mikerickson]

I think this will put the dots where you want them.

Sub test()
    Dim strWord As String
    Dim i As Long
    Dim Size As Long
    strWord = "Football"
    
    Size = Len(strWord) - 1
    
    With Range("A:A")
        .EntireColumn.ClearContents
        .Cells(1, 1).Value = strWord
        
        For i = 1 To ((2 ^ Size) - 1)
            With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                .Value = Replace(Replace(LaceStrings(strWord, WorksheetFunction.Dec2Bin(i, Size)), "0", vbNullString), "1", ".")
            End With
        Next i
    End With
End Sub


Function LaceStrings(ByVal strA As String, ByVal strB As String) As String
    Dim i As Long, lngLength As Long
    Dim strPad As String: strPad = Chr(6)
    lngLength = WorksheetFunction.Max(Len(strA), Len(strB))
    strA = strA & String(lngLength, strPad)
    strB = strB & String(lngLength, strPad)
    For i = 1 To lngLength
        LaceStrings = LaceStrings & Mid(strA, i, 1) & Mid(strB, i, 1)
    Next i
    LaceStrings = Replace(LaceStrings, strPad, vbNullString)
End Function