Condense Dates

[B1313]

Hello,

I have a report that spits out various dates for individuals and they are all in one cell and look like the following:

"10/10, 10/11, 10/12, 10/13, 10/29, 10/30, 10/31, 11/1, 11/5, 11/6, 11/11, 11/30, 12/1, 12/5, 12/10, 12/24, 01/1, etc"

Now this is fine for a detailed report, but I need to condense the data dramatically as that current list could be anywhere from 1 to 120 dates and it is not practical to look at 120 dates individually. Is there a way (macro?) to make that list look like the following?

"10/10 - 10/13, 10/29 - 10/31, 11/1, 11/5 - 11/6, ..."

OR

"Oct (10 - 13, 29 - 31), Nov (1, 5 - 6, 11, 30), Dec (..." <-- Preferred

The second one is the most preferred display, but the first would work too. Ideally this will apply to hundreds of cells down thousands of rows.

Thanks,

 

[gaz_chops]

Didn't read the question properly!!

 

[Rick Rothstein]

Ideally this will apply to hundreds of cells down thousands of rows.

Did you mean hundreds of "columns" when you said "cells"?

Did you want the original data overwritten by the condensed text within the same cell or did you want the condensed text written elsewhere (if elsewhere, where would that be)?

 

[B1313]

Did you mean hundreds of "columns" when you said "cells"?

Did you want the original data overwritten by the condensed text within the same cell or did you want the condensed text written elsewhere (if elsewhere, where would that be)?

Yes I did, sorry, though I would like the most flexible solution for future problems of similar sorts.

As for having data being overwritten, that is fine. So yeah, replacing the long data with the new short data would be perfect.

 

[Rick Rothstein]

Yes I did, sorry, though I would like the most flexible solution for future problems of similar sorts.

As for having data being overwritten, that is fine. So yeah, replacing the long data with the new short data would be perfect.

Okay, I think this macro will do what you want (make sure to test it on a copy of your real data)...

[table="width: 500"]
[tr]
	[td]Sub CondenseDates()
  Dim R As Long, C As Long, X As Long, LastItem As Long, Data As Variant, Txt As String, Dtes() As String
  Data = Range("A1").CurrentRegion
  For R = 1 To UBound(Data, 1)
    For C = 1 To UBound(Data, 2)
      Dtes = Split(Replace(Replace(Data(R, C), " ", ""), ",", "/2000,") & ",", ",")
      If CDate(Left(Dtes(UBound(Dtes) - 2), Len(Dtes(UBound(Dtes) - 2)) - 5)) > CDate(Dtes(UBound(Dtes) - 1)) Then
        Dtes(UBound(Dtes) - 1) = Dtes(UBound(Dtes) - 1) & "/2001"
      Else
        Dtes(UBound(Dtes) - 1) = Dtes(UBound(Dtes) - 1) & "/2000"
      End If
      Dtes(UBound(Dtes)) = Dtes(UBound(Dtes) - 1)
      Txt = ""
      LastItem = 0
      For X = 1 To UBound(Dtes)
        If CDate(Dtes(X - 1)) + 1 <> CDate(Dtes(X)) Then
          If X - LastItem = 1 Then
            Txt = Txt & ", " & Format(Dtes(LastItem), "m/d")
            LastItem = X
          Else
            Txt = Txt & ", " & Format(Dtes(LastItem), "m/d") & "-" & Format(Dtes(X - 1), "m/d")
            LastItem = X
          End If
        End If
      Next
      Data(R, C) = Mid(Txt, 3)
    Next
  Next
  Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub[/td]
[/tr]
[/table]

 

[B1313]

Okay, I think this macro will do what you want (make sure to test it on a copy of your real data)...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub CondenseDates()
  Dim R As Long, C As Long, X As Long, LastItem As Long, Data As Variant, Txt As String, Dtes() As String
  Data = Range("A1").CurrentRegion
  For R = 1 To UBound(Data, 1)
    For C = 1 To UBound(Data, 2)
      Dtes = Split(Replace(Replace(Data(R, C), " ", ""), ",", "/2000,") & ",", ",")
      If CDate(Left(Dtes(UBound(Dtes) - 2), Len(Dtes(UBound(Dtes) - 2)) - 5)) > CDate(Dtes(UBound(Dtes) - 1)) Then
        Dtes(UBound(Dtes) - 1) = Dtes(UBound(Dtes) - 1) & "/2001"
      Else
        Dtes(UBound(Dtes) - 1) = Dtes(UBound(Dtes) - 1) & "/2000"
      End If
      Dtes(UBound(Dtes)) = Dtes(UBound(Dtes) - 1)
      Txt = ""
      LastItem = 0
      For X = 1 To UBound(Dtes)
        If CDate(Dtes(X - 1)) + 1 <> CDate(Dtes(X)) Then
          If X - LastItem = 1 Then
            Txt = Txt & ", " & Format(Dtes(LastItem), "m/d")
            LastItem = X
          Else
            Txt = Txt & ", " & Format(Dtes(LastItem), "m/d") & "-" & Format(Dtes(X - 1), "m/d")
            LastItem = X
          End If
        End If
      Next
      Data(R, C) = Mid(Txt, 3)
    Next
  Next
  Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

It keeps breaking saying
"Run time error '9'
Subscript out of range"

 

[Rick Rothstein]

It keeps breaking saying
"Run time error '9'
Subscript out of range"

On what line of code?

Does your data start in cell A1?

If you go into Debug mode, execute this line of code in the Immediate Window and tell us what prints out...

?Data(R,C)

 

[B1313]

On what line of code?

Does your data start in cell A1?

If you go into Debug mode, execute this line of code in the Immediate Window and tell us what prints out...

?Data(R,C)

No, it does not. It errors on the line:

[COLOR=#333333][FONT=monospace][I] If CDate(Left(Dtes(UBound(Dtes) - 2), Len(Dtes(UBound(Dtes) - 2)) - 5)) > CDate(Dtes(UBound(Dtes) - 1)) Then[/I][/FONT][/COLOR]

I will do the following in just a sec.

 

[Rick Rothstein]

No, it does not.

Does your answer mean your data does not start on cell A1? If so, then where is your data located at (that would be the problem, by the way, as you did not say where your data was so I assumed it started in cell A1)?

 

[B1313]

Does your answer mean your data does not start on cell A1? If so, then where is your data located at (that would be the problem, by the way, as you did not say where your data was so I assumed it started in cell A1)?

Indeed. My data starts at G17, though that can shift. Is it possible to make the solution dynamic to the range selected?