vba help - Split two dates and pick max date

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
812
Office Version
  1. 2010
Platform
  1. Windows
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


VBA 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

End Sub

Below is my data with expected output in Column B.

VBA Code:
[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
 

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Dave Patton

Well-known Member
Joined
Feb 15, 2002
Messages
4,465
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
T202011a.xlsm
AB
228-04-2020/09-05-202009-May-2020
301-07-2020-02-06-202001-Jul-2020
1f
Cell Formulas
RangeFormula
B2:B3B2=MAX(LEFT(A2,10),RIGHT(A2,10))
 

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
812
Office Version
  1. 2010
Platform
  1. Windows
Hi Dave,

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

Below is a table.

Book28
AB
1Date ColumnExpected Output After Split + 15 Days Added
228-04-2020/09-05-202024/05/2020
301-07-2020/02-07-202017/07/2020
431/08/202015/09/2020
531/07/201915/08/2019
602/09/202017/09/2020
710/09/202025/09/2020
818/09/202003/10/2020
924/09/202009/10/2020
1001-07-2020-02-06-202016/07/2020
1101-07-2020-02-08-202017/08/2020
Sheet1


Thanks
mg
 

Dave Patton

Well-known Member
Joined
Feb 15, 2002
Messages
4,465
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
T202011a.xlsm
AB
1
228-04-2020/09-05-202024-May-2020
301-07-2020-02-06-202016-Jul-2020
4
5
1f
Cell Formulas
RangeFormula
B2:B3B2=MAX(LEFT(A2,10),RIGHT(A2,10))+15
 

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
812
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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.

VBA 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
AB
1Date ColumnExpected Output After Split + 15 Days Added
228-04-2020/09-05-202024/05/2020
301-07-2020/02-07-202017/07/2020
431/08/202015/09/2020
531/07/201915/08/2019
602/09/202017/09/2020
710/09/202025/09/2020
818/09/202003/10/2020
924/09/202009/10/2020
1001-07-2020-02-06-202016/07/2020
1101-07-2020-02-08-202017/08/2020
Sheet1


Thanks
mg
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,474
Office Version
  1. 365
Platform
  1. Windows
What about this simpler approach?

VBA Code:
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

Well-known Member
Joined
Feb 4, 2009
Messages
812
Office Version
  1. 2010
Platform
  1. Windows
Hi Peter

Thats Great ! , it worked, So short code,

Thanks you so much for help ! 🕺(y)


Thanks
mg
 

Watch MrExcel Video

Forum statistics

Threads
1,118,126
Messages
5,570,332
Members
412,319
Latest member
akshat1231
Top