How can I convert these inelegant formulae into VBA? - vba

Question

Good people of Stackland
I'm analysing strings comprised of 5 alpha chars which in their raw format look like this;
A2) BCDBE
A3) TLDPP
A4) FGGFC
A5) BBGBB
I need a way of evaluating each character to identify patterns within the strings themselves, eg repeating letters. I want to represent these patterns as follows, where the 1st letter is always given as "A", the 2nd "B"...;
A2) BCDBE --> ABCAD
A3) TLDPP --> ABCDD
A4) FGGFC --> ABBAC
A5) BBGBB --> AABAA
Now, I have achieved this with some pretty inelegant conditional formulae but had to do this to evaluate each character individually, as follows;
1) =IF(LEFT(A2,1)>0,"A")
2) =IF(MID(A2,2,1)=LEFT(A2,1),"A","B")
3) =IF(MID(A2,3,1)=LEFT(A2,1),"A",IF(MID(A2,3,1)=MID(A2,2,1),M2,CHAR(CODE(M2)+1)))
4) =IF(MID(A2,4,1)=LEFT(A2,1),"A",IF(MID(A2,4,1)=MID(A2,2,1),M2,IF(MID(A2,4,1)=MID(A2,3,1),N2,CHAR(MAX(CODE(L2:N2)+1)))))
5) =IF(MID(A2,5,1)=LEFT(A2,1),"A",IF(MID(A2,5,1)=MID(A2,2,1),M2,IF(MID(A2,5,1)=MID(A2,3,1),N2,IF(MID(A2,5,1)=MID(A2,4,1),O2,CHAR(MAX(CODE(L2:O2)+1))))))
Translated...
1) Call the first character "A"
2) If the 2nd character is the same as the same as the 1st call it "A", otherwise cause it "B"
3) If the 3rd character is the same as the 1st call it "A", if it's the same as the 2nd call it whatever the 2nd is, if not give it the value of the next letter, ie "C"
4) If the 4th character is the same as the 1st, call it "A", if it's the sames as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is, if not then call it the next letter in the alphabet, ie "D"
5) If the 5th character is the same as the 1st, call it "A", if it's the same as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is called, if it's the same as the 4th call it whatever the 4th is called, if not then call it the next letter in the alphabet, ie "E"
I'm doing this over 5 cols, one formula per col, and the concatenating the 5 results into one cell to get AABAA or whatever.
I just need to know if there's a nice, clean VBA solution to this.
Any ideas?

Answer 1

Here is the a Function to do the letter instead of numbers:
Function findPattern(inputStr As String) As String
Dim i As Integer
Dim t As Integer
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
findPattern = inputStr
End Function
Put it in a module attached to the workbook, and you can call it thus:
=findPattern(A2)
Driectly from the worksheet where A2 is the cell you want tested.
Or from vba:
Sub test()
Dim str as string
str = findPattern(Range("A2").value)
debug.print str
End Sub
Edit: By your Comment I assume you have more than just the first 5 characters that you want left original. If that is the case use this:
Function findPattern(Str As String) As String
Dim inputStr As String
Dim i As Integer
Dim t As Integer
inputStr = Left(Str, 5)
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
'This is the return line. As is it will only return 5 characters.
'If you want the whole string with only the first five as the pattern
'Remove the single quote in the middle of the string.
findPattern = inputStr '& Mid(Str, 6, (Len(Str)))
End Function

Answer 2

This seems like an easy approach:
's is the input string
dim pos, c, s_new, s_old
pos = 1 : c = 49
s_new = mid(s, 1, 5) ' take only first five characters
do while pos <= 5
s_old = s_new
s_new = replace(s_new, mid(s, pos, 1), chr(c))
if s_new <> s_old then c = c + 1
loop
s_new = replace(s_new, "1", "A")
s_new = replace(s_new, "2", "B")
s_new = replace(s_new, "3", "C")
s_new = replace(s_new, "4", "D")
s_new = replace(s_new, "5", "E")
'm assuming that you don't have any numeric characters in your input.

Answer 3

This has a certain elegance:
Function Pattern(r As Range)
Dim c&, i&, a
Const FORMULA = "iferror(find(mid(~,{2,3,4,5},1),left(~,{1,2,3,4})),)"
a = Evaluate(Replace(FORMULA, "~", r.Address))
c = 1: Pattern = "A"
For i = 1 To 4
If a(i) = 0 Then c = c + 1: a(i) = c
Pattern = Pattern & Chr$(64 + a(i))
Next
End Function

Answer 4

I had this for a while (it's handy for cryptograms), so I'll post it:
Function Pattern(ByVal sInp As String) As String
' shg 2012
' Returns the pattern of a string as a string of the same length
' First unique letter and all repeats is a, second is b, …
' E.g., Pattern("mississippi") returns "abccbccbddb"
Dim iChr As Long ' character index to sInp & Pattern
Dim sChr As String ' character in sInp
Dim iPos As Long ' position of first appearance of sChr in sInp
sInp = LCase(Trim(sInp))
If Len(sInp) Then
sChr = Chr(64)
Pattern = sInp
For iChr = 1 To Len(sInp)
iPos = InStr(sInp, Mid(sInp, iChr, 1))
If iPos = iChr Then ' it's new
sChr = Chr(Asc(sChr) + 1)
Mid(Pattern, iChr) = sChr
Else
Mid(Pattern, iChr) = Mid(Pattern, iPos, 1)
End If
Next iChr
End If
End Function