Finding text value and move it different column - excel

Question

I need your help to build a macro that can extract the dates (which are in text format) from a string and report them in a different column - let's say to column K, would you be able to assist?
Below the database in text
Contract
OESX BLT 100 Feb22 Mar22 4200 vs S 5 FESX Mar22 #4080
OESX P 100 Mar22 3050 vs 6 FESX Mar22 #4080
OESX CDIA 100 Feb22 4300 Mar22 4400 vs B 3 FESX Mar22 #4090
OESX CNV 100 Dec23 4100 vs 100 FESX Mar22 #4100
OESX PBUT Feb22 3900 - 4000 - 4100
The length of the column of the database is not fixed, it changes every time.
The final goal would be to put the dates at the beginning of the contract and not in the middle.
I thank you in advance :)
CODE:
Sub Macro8()
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim row
Dim column
Dim value
fndList = Array("Dec22 ", "Dec23 ")
rplcList = Array("", "")
Set sht = Sheets("Data")
****For Each cell In Range("A2:A40")
If InStr(cell.Text, fndList) > 0 Then
cell.Offset(0, 1).value = fndList
End If
Next cell****
For x = LBound(fndList) To UBound(fndList)
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next x
End Sub

Answer 1

Simple original answer:
Function RearrangeContract(ref As String)
Dim I As Integer
Dim N As Integer
Dim Res As String
Dim Con As String
Con = ref
For I = 1 To Len(ref) - 3
For N = 1 To 12
If Mid(ref, I, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
Res = Res & Mid(ref, I, 5) & " "
Con = Replace(Con, Mid(ref, I, 6), "")
End If
Next N
Next I
RearrangeContract = Res & Con
End Function
Should spit out strings exactly as you requested.
[enter image description here][1]
Either use the function in your own code, or import the contract lines into excel and use =RearrangeContract() as a UDF
And here we have an absolute mess of code for such a small task, but I'm roughly 90% sure it will work perfectly.
FYI: I went the lazy route for the sorting, and borrowed a sorting sub from here: https://bettersolutions.com/vba/arrays/sorting-counting-sort.htm
Should rearrange, sort and filter duplicates
in the top function, you can change the date output format here:
"Res(i) = Format(Res(i), "mmmyy")"
Option Explicit
Option Base 0
Function RearrangeContractUnique(ref As String)
Dim i As Integer 'Character counter
Dim N As Integer 'Month counter
Dim Res() 'Result
Dim Con As String 'Contract - dates
Dim CNT As Integer 'Date found counter
Dim Temp
CNT = 0 'Counter to 0
Con = ref 'Store reference separately
For i = 1 To Len(ref) - 3 'Cycle through character in ref
For N = 1 To 12 'Test each month againt section of ref
If Mid(ref, i, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
CNT = CNT + 1 'Increment counter
ReDim Preserve Res(1 To CNT) 'Resize array
'Debug.Print Mid(ref, i + 3, 2)
Res(CNT) = DateValue(DateSerial(20 & Mid(ref, i + 3, 2), N, 1))
Con = Replace(Con, Mid(ref, i, 6), "") 'Remove date found from ref
End If
Next N
Next i
'Debug.Print "PreSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
Array_CountingSort Res
'Debug.Print "PostSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
'Reformat for output
For i = 1 To CNT
Res(i) = Format(Res(i), "mmmyy")
Next i
'Yeah, just shovel more worksheetfunctions into it.
RearrangeContractUnique = Join(Application.WorksheetFunction.Transpose _
(WorksheetFunction.Unique(Application.WorksheetFunction. _
Transpose(Res())))) & " " & Con
End Function
Public Sub Array_CountingSort(ByRef vArrayName As Variant)
Dim vCounting() As Long
Dim lLower As Long
Dim lUpper As Long
Dim larraymin As Long
Dim larraymax As Long
Dim i As Long
Dim j As Long
Dim lnextpos As Long
larraymin = Helper_Minimum(vArrayName)
larraymax = Helper_Maximum(vArrayName)
lLower = LBound(vArrayName)
lUpper = UBound(vArrayName)
ReDim vCounting(larraymin To larraymax)
For i = lLower To lUpper
vCounting(vArrayName(i)) = vCounting(vArrayName(i)) + 1
Next i
lnextpos = lLower
For i = larraymin To larraymax
For j = 1 To vCounting(i)
vArrayName(lnextpos) = i
lnextpos = lnextpos + 1
Next j
Next i
End Sub
Public Function Helper_Maximum(ByVal vArrayName As Variant) As Long
Dim lmaxvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lmaxvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) > lmaxvalue) Then
lmaxvalue = vArrayName(i)
End If
Next i
Helper_Maximum = lmaxvalue
End Function
Public Function Helper_Minimum(ByVal vArrayName As Variant) As Long
Dim lminvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lminvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) < lminvalue) Then
lminvalue = vArrayName(i)
End If
Next i
Helper_Minimum = lminvalue
End Function