Decode excel date mask - excel

Question

I need to try to find an algorithm to decode a set of Excel dates.
A former employee once told me he could encode a date in Excel and no one would ever figure it out, he said "like a needle in a haystack". My response was "Why would someone want to do that?" After his departure with the theft of a large amount of data, I find a set of charts with "record numbers" labeled anywhere from from T20000 to T39999. These charts should have accompanying birthdates, but do not - the birthdates are missing. These charts were hidden in our usual charts which are 6 to 7 digits and pure numeric only rather than starting with a "T". Given this background(and other data), I doubt this was done for innocent reasons and suspect fraud, such as Medicare or insurance fraud. The 5 digits after the "T" could encode the birthdates. These are similar to the usual 5 digit numbers Excel uses to store dates. I was able to find some birthdates by finding other ways to look them up. A few examples are:
Record # Exel DOB (real) DOB
T30007 27369 12/6/1974
T31414 16803 1/1/1946
T31738 22156 8/28/1960
There are 2-3 K of these without birthdates.
Simple addition or subtraction does not find the answer. I suspect he added(or subtracted) then flipped the individual digits, then added(or subtracted) again or a similar algorithm. Changing the order of the 5 digits like 5 cards in poker(The former employee played a lot of poker).
I wrote an Excel VBA program to try to evaluate this using trials of: 1) adding 1 to 9999, 2) then switching the order of the last 4 digits, then 3) adding or subtracting 1 to 9999. However, the number of possibilities (9999 * 2^4 * 9999 * 2 ) far exceeds the row limits in Excel(with non matches excluded) and breaking it into smaller parts still ran too slowly on my non gaming computers. I am not well versed in C, Java or Python, but suspect these may be better options.
My slow running Excel VBA code:
Sub Decode_DOB()
'The accompanying table is Sheet1 which this runs off
Dim Org(111, 5) As Long
Dim BD1(111, 5) As Long
Dim Var_1(111, 5) As Long
Dim VarTT(111) As Long
Dim VarTT1(111) As Long
Dim VarTT2(111) As Long
Dim Save_Counter As Long
Dim icounter As Long
Dim int_Digit_Count As Integer
Save_Counter = 1 'Counter to save the spreadsheet at intervals
icounter = 2 'Counter to keep track of current row number
'Org(x,y) array to store the original chart record starting with "T"
'Org(n2,0) for the total 5 digit number, then Org(n2,1 to 5) to break out each digit
For n2 = 2 To 25
Org(n2, 0) = Sheet1.Cells(n2, 2).Value
Org(n2, 1) = Mid(Org(n2, 0), 1, 1)
Org(n2, 2) = Mid(Org(n2, 0), 2, 1)
Org(n2, 3) = Mid(Org(n2, 0), 3, 1)
Org(n2, 4) = Mid(Org(n2, 0), 4, 1)
Org(n2, 5) = Mid(Org(n2, 0), 5, 1)
Next n2
'BD1(x,y) array to store the original chart record starting with "T"
'BD1(n1,0) for the total 5 digit number, then BD1(n1,1 to 5) to break out each digit
For n1 = 2 To 25
BD1(n1, 0) = Sheet1.Cells(n1, 28).Value
BD1(n1, 1) = Mid(BD1(n1, 0), 1, 1)
BD1(n1, 2) = Mid(BD1(n1, 0), 2, 1)
BD1(n1, 3) = Mid(BD1(n1, 0), 3, 1)
BD1(n1, 4) = Mid(BD1(n1, 0), 4, 1)
BD1(n1, 5) = Mid(BD1(n1, 0), 5, 1)
Next n1
'Sequentially try adding 1 to 9999
For n = 1 To 9999
For i = 2 To 25
Var_1(i, 0) = Org(i, 0) - n
Var_1(i, 1) = Mid(Var_1(i, 0), 1, 1)
Var_1(i, 2) = Mid(Var_1(i, 0), 2, 1)
Var_1(i, 3) = Mid(Var_1(i, 0), 3, 1)
Var_1(i, 4) = Mid(Var_1(i, 0), 4, 1)
Var_1(i, 5) = Mid(Var_1(i, 0), 5, 1)
'Sequentially "Flip the digits" or "Cards" only using the last 4
For k = 2 To 5
For l = 2 To 5
For m = 2 To 5
For p = 2 To 5
'Combine digits to get the total 5 digit number
VarTT(i) = Var_1(i, 1) * 10000 + Var_1(i, k) * 1000 + Var_1(i, l) * 100 + Var_1(i, m) * 10 + Var_1(i, p)
'Sequentially and and subtract from the result
For ii = 1 To 9999
VarTT1(i) = VarTT(i) + ii
VarTT2(i) = VarTT(i) - ii
'Test valid "Flips" - only one of each digit allowed
'and the total 1+2+3+4+5 should = 15
int_Digit_Count = 1 + k + l + m + p
If (k = l Or k = m) Or k = p Then
int_Digit_Count = 0
End If
If l = m Or l = p Then
int_Digit_Count = 0
End If
If m = p Then
int_Digit_Count = 0
End If
'test to see if the result matches the birthdate
If VarTT1(i) = BD1(i, 0) Or VarTT2(i) = BD1(i, 0) Then
'and test for valid "Flip"
If int_Digit_Count = 15 Then
'If the sequence and valid flip creates a match, write to Sheet2
Sheet2.Cells(icounter, 1).Value = i
Sheet2.Cells(icounter, 2).Value = Org(i, 0)
Sheet2.Cells(icounter, 3).Value = Org(i, 0) - n
Sheet2.Cells(icounter, 4).Value = VarTT(i)
Sheet2.Cells(icounter, 5).Value = BD1(i, 0)
Sheet2.Cells(icounter, 6).Value = n
Sheet2.Cells(icounter, 7).Value = Var_1(i, 1)
Sheet2.Cells(icounter, 8).Value = Var_1(i, 2)
Sheet2.Cells(icounter, 9).Value = Var_1(i, 3)
Sheet2.Cells(icounter, 10).Value = Var_1(i, 4)
Sheet2.Cells(icounter, 11).Value = Var_1(i, 5)
Sheet2.Cells(icounter, 13).Value = 1
Sheet2.Cells(icounter, 14).Value = k
Sheet2.Cells(icounter, 15).Value = l
Sheet2.Cells(icounter, 16).Value = m
Sheet2.Cells(icounter, 17).Value = p
Sheet2.Cells(icounter, 19).Value = VarTT1(i)
Sheet2.Cells(icounter, 20).Value = VarTT2(i)
Sheet2.Cells(icounter, 21).Value = ii
FlipPattern = 1 * 10000 + k * 1000 + l * 100 + m * 10 + p
Sheet2.Cells(icounter, 22).Value = FlipPattern
icounter = icounter + 1
'Save the spreadsheet every 5000 rows in case the program "blows up"
Save_Counter = Save_Counter + 1
If Save_Counter > 5000 Then
ActiveWorkbook.Save
Save_Counter = 1
Sheet2.Cells(1, 12).Value = icounter
Sheet2.Cells(icounter, 24).Value = Time()
Application.Wait (Now + TimeValue("00:00:01"))
End If
End If
End If
'ii for last number added or subtracted
Next ii
'p,m,l,k for flip sequences
Next p
Next m
Next l
Next k
'For each "T" number on Sheet 1
Next i
Next n
'Matches can then be sorted on n, "Flip" and ii and look for a "common denominator"
End Sub
Sub Sort_Matches()
'Run this after sorting to mark multiple matches and filter
last_row = Sheet5.Cells(Rows.count, 1).End(xlUp).Row
For ijj = 2 To last_row
If Sheet5.Cells(ijj, 6).Value = Sheet5.Cells(ijj - 1, 6).Value Then
If Sheet5.Cells(ijj, 21).Value = Sheet5.Cells(ijj - 1, 21).Value Then
If Sheet5.Cells(ijj, 22).Value = Sheet5.Cells(ijj - 1, 22).Value Then
Sheet5.Cells(ijj - 1, 23).Value = "XX"
Sheet5.Cells(ijj, 23).Value = "XX"
End If
End If
End If
Next ijj
End Sub