Convert String Characters to Text - excel

Question

I'm trying to convert a large amount of data into a written description of the text. Ex. Convert YYYY####### to "4 digit year, 7 numeric digits" and YYMMDD-#### to "2 digit year, 2 digit month, 2 digit day, hyphen, 4 numeric digits"
The constant characters are Y, M, D, #, - and X (X is for non-defined alpha characters). There are some defined alpha characters (Y, M, D and X are never used for anything other than Year, Month, Day and Alpha respectively) that are used, ie (RP-YYYY#####) where I want to try to capture those (anything other than the constant characters) and state them as they are. So the written text for RP-YYYY##### would be "RP, hypen, 4 digit year, 5 numeric digits"
I'm able to get a count of each character using the Len and Replace methods, however I'm struggling to figure out how to produce the written text in the correct order, or to capture non constant characters like RP and state them as is.
Any help would be much appreciated!
Sub getcharacters()
Dim casenumber As String
casenumber = Range("A1")
InitialCount = Len(casenumber)
YearDigits = Len(casenumber) - Len(Replace(casenumber, "Y", ""))
MonthDigits = Len(casenumber) - Len(Replace(casenumber, "MM", ""))
DayDigits = Len(casenumber) - Len(Replace(casenumber, "DD", ""))
NumberDigits = Len(casenumber) - Len(Replace(casenumber, "#", ""))
AlphaDigits = Len(casenumber) - Len(Replace(casenumber, "X", ""))
HyphenDigits = Len(casenumber) - Len(Replace(casenumber, "-", ""))
FinalCount = InitialCount - YearDigits - MonthDigits - DayDigits - Digits - AlphaDigits
If YearDigits = "0" Then WrittenYear = ""
If YearDigits = "2" Then WrittenYear = "Two digit year"
If YearDigits = "4" Then WrittenYear = "Four digit year"
If MonthDigits = "0" Then WrittenMonth = "" Else WrittenMonth = "Two digit month"
If DayDigits = "0" Then WrittenDay = "" Else WrittenDay = "Two digit day"
If NumberDigits = "0" Then WrittenDigits = "" Else WrittenDigits = NumberDigits & " digits"
If AlphaDigits = "0" Then WrittenAlpha = "" Else WrittenAlpha = AlphaDigits & " alpha characters"
WrittenCaseNumber = WrittenYear & WrittenMonth & WrittenDay & WrittenDigits & WrittenAlpha
End Sub

Answer 1

You may use Regex for the matching and replacing part along with some helper functions to convert digits to words, etc. I admit it's a bit ugly but it does the trick.
First, add the following two references to your project:
Microsoft VBScript Regular Expressions 5.5
Microsoft Scripting Runtime
Second, add the following code to a Module:
Option Explicit
Private DictAlphaCharacters As Scripting.Dictionary
Private Sub InitializeDictAlphaCharacters()
Set DictAlphaCharacters = New Scripting.Dictionary
DictAlphaCharacters.Add "Y", "digit year"
DictAlphaCharacters.Add "M", "digit month"
DictAlphaCharacters.Add "D", "digit day"
DictAlphaCharacters.Add "#", "numeric digits"
End Sub
Public Function DescribeThis(s As String) As String
If DictAlphaCharacters Is Nothing Then InitializeDictAlphaCharacters
Dim tmpStr As String: tmpStr = s
Dim regEx As New RegExp
regEx.Global = True
Dim matches As MatchCollection
Dim m As Match
Dim k As Variant ' Dictionary key.
Dim alpha As String ' The corresponding sentence for an alpha char.
Dim l As Integer ' Length of the matched string (consecutive alpha chars).
Dim w As String ' The corresponding word of a digit.
For Each k In DictAlphaCharacters.Keys
alpha = DictAlphaCharacters.Item(k)
regEx.Pattern = k & "{1,9}"
Set matches = regEx.Execute(tmpStr)
For Each m In matches
l = m.Length
w = DigitToWord(l)
' Pattern ex. = "([^Y])?,?Y{2}(?!Y)"
regEx.Pattern = "([^" & k & "])?,?" & k & "{" & l & "}(?!" & k & ")"
' Replacement example: "$1,Two digit year,"
tmpStr = regEx.Replace(tmpStr, "$1," & w & " " & alpha & ",")
Next
Next
regEx.Pattern = ",?-,?"
tmpStr = regEx.Replace(tmpStr, ",hyphen,")
regEx.Pattern = "^,+|,+$"
DescribeThis = regEx.Replace(tmpStr, "")
End Function
Public Function DigitToWord(d As Integer) As String
Select Case d
Case 1: DigitToWord = "One"
Case 2: DigitToWord = "Two"
Case 3: DigitToWord = "Three"
Case 4: DigitToWord = "Four"
Case 5: DigitToWord = "Five"
Case 6: DigitToWord = "Six"
Case 7: DigitToWord = "Seven"
Case 8: DigitToWord = "Eight"
Case 9: DigitToWord = "Nine"
End Select
End Function
Usage:
Sub Test()
Debug.Print DescribeThis("YYYY#######")
Debug.Print DescribeThis("YYMMDD-####")
Debug.Print DescribeThis("RP-YYYY#####")
Debug.Print DescribeThis("YYYMMM-YYMM")
End Sub
Output:
Four digit year,Seven numeric digits
Two digit year,Two digit month,Two digit day,hyphen,Four numeric digits
RP,hyphen,Four digit year,Five numeric digits
Three digit year,Three digit month,hyphen,Two digit year,Two digit month

Answer 2

This seems to accomplish what you want.
As written it assumes that all of the "like" characters in the set of [YMD#] are contiguous. If groups of Y's, for example, could repeat in different parts of the string, we just need to change the charCnt function.
Option Explicit
'set reference to Microsoft Scripting Runtime
Function convStr(S As String) As String
Dim myDict As Dictionary
Dim sRes() As String
Dim I As Long
Dim CH As String
Set myDict = New Dictionary
myDict.CompareMode = TextCompare
myDict.Add "Y", "digit year"
myDict.Add "M", "digit month"
myDict.Add "D", "digit day"
myDict.Add "#", "numeric digits"
myDict.Add "-", "hyphen"
ReDim sRes(0)
For I = 1 To Len(S)
CH = Mid(S, I, 1)
If myDict.Exists(CH) Then
sRes(UBound(sRes)) = IIf(CH <> "-", charCnt(S, CH) & " ", "") & myDict(CH)
I = I + charCnt(S, CH)
Else
Do While Not myDict.Exists(CH)
sRes(UBound(sRes)) = sRes(UBound(sRes)) & CH
I = I + 1
CH = Mid(S, I, 1)
Loop
End If
I = I - 1
ReDim Preserve sRes(UBound(sRes) + 1)
Next I
ReDim Preserve sRes(UBound(sRes) - 1)
convStr = Join(sRes, ", ")
End Function
Function charCnt(S As String, CH As String) As Long
Dim startChar As Long
startChar = InStr(S, CH)
If startChar > 0 Then
charCnt = Len(S) - Len(Replace(S, CH, ""))
Else
charCnt = 0
End If
End Function