Finding text value and move it different column-CodePudding

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?

databaseimage

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

CodePudding user response：

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