vba help - Split two dates and pick max date

[Mallesh23]

Hi Team,

Need your help to split date Column(A) if there are two dates in cell.
find max dates and it will be output. and add grace 15 days to each day.

these are two pattern needs to split.
28-04-2020/09-05-2020
01-07-2020-02-06-2020


Below is my attempted code, Covered only "/" Seperator.
macro needs to handle Pattern==> 01-07-2020-02-06-2020

Sub test()

    Dim arr_date As Variant
    arr_date = Range("a2:a11").Value
    Dim AddExtraDays As Long
   
   ' Read through the data, if two dates find max date ,add 15 days to each date
        
        AddExtraDays = 15
    
    Dim dict As New Scripting.Dictionary
        dict.RemoveAll
        dict.CompareMode = TextCompare
    
        Dim i As Long
        Dim strdate As Date
    
    '--------------
    On Error Resume Next
    For i = LBound(arr_date, 1) To UBound(arr_date, 1)
        If Len(arr_date(i, 1)) > 12 Then
            strdate = Split(arr_date(i, 1), "/")(1)
            arr_date(i, 1) = CDate(strdate) + AddExtraDays
        Else
            arr_date(i, 1) = CDate(arr_date(i, 1)) + AddExtraDays
            End If
    Next i
    On Error GoTo 0
       
    
    Range("b2:b11").Value = arr_date

End Sub

Below is my data with expected output in Column B.

[RANGE=rs:11|cs:2|w:Book28|cls:xl2bb-127|s:Sheet1|tw:322][XR][XH][/XH][XH=w:112]A[/XH][XH=w:210]B[/XH][/XR][XR][XH]1[/XH][XD=h:l|bc:FFFF00|ch:14.5|cls:bb]Date Column[/XD][XD=h:l|bc:FFD966|cls:bb]Expected Output After Split + 15 Days Added[/XD][/XR][XR][XH]2[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb]28-04-2020/09-05-2020[/XD][XD=h:c|bc:00B050|cls:bl bt br bb|tx:24/05/2020]24/05/2020[/XD][/XR][XR][XH]3[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb]01-07-2020/02-07-2020[/XD][XD=h:c|bc:00B050|cls:bl bt br bb|tx:17/07/2020]17/07/2020[/XD][/XR][XR][XH]4[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb|tx:31/08/2020]31/08/2020[/XD][XD=h:c|cls:bl bt br bb|tx:15/09/2020]15/09/2020[/XD][/XR][XR][XH]5[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb|tx:31/07/2019]31/07/2019[/XD][XD=h:c|cls:bl bt br bb|tx:15/08/2019]15/08/2019[/XD][/XR][XR][XH]6[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb|tx:02/09/2020]02/09/2020[/XD][XD=h:c|cls:bl bt br bb|tx:17/09/2020]17/09/2020[/XD][/XR][XR][XH]7[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb|tx:10/09/2020]10/09/2020[/XD][XD=h:c|cls:bl bt br bb|tx:25/09/2020]25/09/2020[/XD][/XR][XR][XH]8[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb|tx:18/09/2020]18/09/2020[/XD][XD=h:c|cls:bl bt br bb|tx:03/10/2020]03/10/2020[/XD][/XR][XR][XH]9[/XH][XD=h:l|ch:14.5|cls:bt br bb|tx:24/09/2020]24/09/2020[/XD][XD=h:c|cls:bl bt br bb|tx:09/10/2020]09/10/2020[/XD][/XR][XR][XH]10[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb]01-07-2020-02-06-2020[/XD][XD=h:c|bc:00B050|cls:bl bt br bb|tx:16/07/2020]16/07/2020[/XD][/XR][XR][XH]11[/XH][XD=h:l|v:m|ch:14.5|cls:bl bt br bb]01-07-2020-02-08-2020[/XD][XD=h:c|bc:00B050|cls:bl bt br bb|tx:17/08/2020]17/08/2020[/XD][/XR][/RANGE]

Thanks
mg

 

[Dave Patton]

T202011a.xlsm
	A	B
2	28-04-2020/09-05-2020	09-May-2020
3	01-07-2020-02-06-2020	01-Jul-2020
1f

Cell Formulas
Range	Formula
B2:B3	B2	=MAX(LEFT(A2,10),RIGHT(A2,10))

 

[Mallesh23]

Hi Dave,

Thanks for your help, I am looking help in vba,

Below is a table.

Book28
	A	B
1	Date Column	Expected Output After Split + 15 Days Added
2	28-04-2020/09-05-2020	24/05/2020
3	01-07-2020/02-07-2020	17/07/2020
4	31/08/2020	15/09/2020
5	31/07/2019	15/08/2019
6	02/09/2020	17/09/2020
7	10/09/2020	25/09/2020
8	18/09/2020	03/10/2020
9	24/09/2020	09/10/2020
10	01-07-2020-02-06-2020	16/07/2020
11	01-07-2020-02-08-2020	17/08/2020
Sheet1

Thanks
mg

 

[Dave Patton]

T202011a.xlsm
	A	B
1
2	28-04-2020/09-05-2020	24-May-2020
3	01-07-2020-02-06-2020	16-Jul-2020
4
5
1f

Cell Formulas
Range	Formula
B2:B3	B2	=MAX(LEFT(A2,10),RIGHT(A2,10))+15

 

[Mallesh23]

Hi Dave,

Formula worked , But I am doing all activity via macro. my data are in different workbooks.
hence taking data into Array and working.

Below is my attempted Code.

Sub test()

    Dim arr_date As Variant
    arr_date = Range("a2:a11").Value
    Dim AddExtraDays As Long
   
   ' Read through the data, if two dates find max date ,add 15 days to each date
        
        AddExtraDays = 15
    
    Dim dict As New Scripting.Dictionary
        dict.RemoveAll
        dict.CompareMode = TextCompare
    
        Dim i As Long
        Dim strdate As Date
    
    '--------------
    On Error Resume Next
    For i = LBound(arr_date, 1) To UBound(arr_date, 1)
        If Len(arr_date(i, 1)) > 12 Then
            strdate = Split(arr_date(i, 1), "/")(1)
            arr_date(i, 1) = CDate(strdate) + AddExtraDays
        Else
            arr_date(i, 1) = CDate(arr_date(i, 1)) + AddExtraDays
            End If
    Next i
    On Error GoTo 0
       
    
    Range("b2:b11").Value = arr_date

Column A is input file.

Book28
	A	B
1	Date Column	Expected Output After Split + 15 Days Added
2	28-04-2020/09-05-2020	24/05/2020
3	01-07-2020/02-07-2020	17/07/2020
4	31/08/2020	15/09/2020
5	31/07/2019	15/08/2019
6	02/09/2020	17/09/2020
7	10/09/2020	25/09/2020
8	18/09/2020	03/10/2020
9	24/09/2020	09/10/2020
10	01-07-2020-02-06-2020	16/07/2020
11	01-07-2020-02-08-2020	17/08/2020
Sheet1

Thanks
mg

 

[Peter_SSs]

What about this simpler approach?

Sub test2()
  Dim arr_date As Variant
  Dim AddExtraDays As Long, i As Long
  Dim Date1 As Date, Date2 As Date
  
  arr_date = Range("a2:a11").Value
  AddExtraDays = 15
  For i = 1 To UBound(arr_date, 1)
    Date1 = DateValue(Left(arr_date(i, 1), 10))
    Date2 = DateValue(Right(arr_date(i, 1), 10))
    arr_date(i, 1) = IIf(Date1 > Date2, Date1, Date2) + 15
  Next i
  Range("b2:b11").Value = arr_date
End Sub

 

[Mallesh23]

Hi Peter

Thats Great ! , it worked, So short code,

Thanks you so much for help ! ?


Thanks
mg

 

[Peter_SSs]

Cheers.