Finding date groups

**OAM** · 01-17-2013, 08:57 PM

I need to find the date groups from a series of dates in a row. As you can see below, I have a series of dates that come from an On-Call schedule using the Macro below. What I need it to do is look at the string of dates and pull out the newest and the oldest dates for each time period, example:

From the dates below, I need it to display the dates like this:
Columns A B C
Person 1 1/10/2013 To 1/16/2013 1/24/2013 To 1/30/2013 3/21/2013 To 3/27/2013
Person 2 1/10/2013 To 2/9/2013

Person 1 Schedule all in one row in a cell each
1/10/2013 1/11/2013 1/12/2013 1/13/2013 1/14/2013 1/15/2013 1/16/2013 1/24/2013 1/25/2013 1/26/2013 1/27/2013 1/28/2013 1/29/2013 1/30/2013 3/21/2013 3/22/2013 3/23/2013 3/24/2013 3/25/2013 3/26/2013 3/27/2013

Person 2 Schedule all in one row in a cell each
1/10/2013 1/11/2013 1/12/2013 1/13/2013 1/14/2013 1/15/2013 1/16/2013 1/17/2013 1/18/2013 1/19/2013 1/20/2013 1/21/2013 1/22/2013 1/23/2013 1/24/2013 1/25/2013 1/26/2013 1/27/2013 1/28/2013 1/29/2013 1/30/2013 2/1/2013 2/2/2013 2/3/2013 2/4/2013 2/5/2013 2/6/2013 2/7/2013 2/8/2013 2/9/2013

I do not need the dates in-between the dates populated in a cell, all I want is just to split out the beginning and the end dates.

Is this possible to do?
I am working with Excel 2007
Thank you for your time!


Sub aaa()
  Dim OutSh As Worksheet
  Set OutSh = Sheets("Sheet7")
  
  For Each ce In Range("B4:US9")
      Set findit = OutSh.Range("A:A").Find(what:=ce.Value)
      If findit Is Nothing Then
        OutSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = ce.Value
        Set findit = OutSh.Range("A:A").Find(what:=ce.Value)
      End If
      OutSh.Cells(findit.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Cells(12, ce.Column).Value
  
  Next ce
End Sub

**coreytroy** · 01-17-2013, 09:38 PM

Can't you simply use a formula such as:
=Min(A1:U1)
=Max(A1:U1)

??

**OAM** · 01-17-2013, 10:39 PM

There are multiple times within the string of dates that the person is on call. Everyday the person is on-call the code adds it to the list (row). Take for instance person one; they are on call 1/10/2013 To 1/16/2013, 1/24/2013 To 1/30/2013, 3/21/2013 To 3/27/2013 and several other times. I need the code or formula to look through the entire row and pull out the groups of dates that go together as shown above.

Is this do able?

**kvsrinivasamurthy** · 01-18-2013, 03:38 AM

PL TRY THIS CODE.
Sheet1 contains data from 2nd row.

Sub Distribute_dates()

Dim LR As Long
Dim T, TA As Integer
Dim F_date1, F_date2 As Date
Dim M, M_date1, M_date2 As Variant

LR = Range("A1").End(xlDown).Row

For T = 2 To LR
M = Split(Range("B" & T), " ")
    For TA = 1 To UBound(M) - 1
    If M(TA) = "To" Then
    M_date1 = Split(M(TA - 1), "/")
    M_date2 = Split(M(TA + 1), "/")
    
    F_date1 = DateSerial(M_date1(2), M_date1(0), M_date1(1))
    F_date2 = DateSerial(M_date2(2), M_date2(0), M_date2(1))


'    F_date2 = Format(M(TA + 1), "shortdate")
        Do While F_date1 <= F_date2
        With Sheets("Sheet" & T)
        If .[A2] = "" Then
         .[A2] = F_date1
        ElseIf .[B2] = "" Then
         .[B2] = F_date1
        Else
         .Range("A2").End(xlToRight).Offset(0, 1) = F_date1
        End If
        F_date1 = F_date1 + 1
   
        End With
        Loop
    End If
    Next TA

Next T
End Sub

**OAM** · 01-23-2013, 11:17 AM

kvsrinivasamurthy,

I was unable to get the code to achieve the results I need so I have up loaded a copy of the file with the data. On Sheet1 is the output data from the code "Sub aaa()" shown below and Sheet2 is the desired output I am looking for each row of dates. Do I need to have each output to a separate sheet or will the output go to one sheet?

Thank you for your help

Book2 .xlsm

**AB33** · 01-23-2013, 04:24 PM

Try this one

Sub findingdate()

Dim x, y(), i&, j&, n&

x = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x) * UBound(x, 2), 1 To 3)
n = 1
For i = 1 To UBound(x)

  y(1, 1) = "01/01/2013"
  y(1, 2) = "to"
   
    For j = 4 To UBound(x, 2) Step 7
     If Len(x(i, j)) Then
            n = n + 1
            y(n, 2) = "to"
            y(n, 1) = x(i, j)
       End If
    Next j
Next i

n = 0
    For i = 1 To UBound(x)

        For j = 3 To UBound(x, 2) Step 7
         If Len(x(i, j)) Then
            n = n + 1
            y(n, 3) = x(i, j)
         End If
       Next j
    Next i
With Sheets("Sheet2")
    .UsedRange.ClearContents
    .Range("A2:C2").Resize(n).Value = y
    .Activate
End With
End Sub

**OAM** · 01-23-2013, 10:56 PM

AB33,

Very Close! The code ran and produced the following on sheet 2 starting at A2:

1/1/2013 1/10/2013
1/11/2013 to 1/24/2013
1/25/2013 to 3/21/2013
3/22/2013 to 4/18/2013
4/19/2013 to 5/16/2013
5/17/2013 to 6/6/2013
6/7/2013 to 8/15/2013
8/16/2013 to 8/22/2013
8/23/2013 to 10/3/2013
10/4/2013 to 10/17/2013
10/18/2013 to 12/19/2013

It should produce the following:

1/1/2013 to 1/2/2013
1/10/2013 to 1/16/2013
1/24/2013 to 1/30/2013
3/21/2013 to 3/27/2013
4/18/2013 to 4/24/2013
5/16/2013 to 5/22/2013
6/6/2013 to 6/12/2013
8/15/2013 to 8/28/2013
10/3/2013 to 10/9/2013
10/17/2013 to 10/23/2013
12/19/2013 to 12/25/2013

The code skipped over several dates in the series, do I need to make any changes to the sheet?

Thank you for your time and help!

**Leith Ross** · 01-24-2013, 01:31 AM

Hello OAM,

This macro will split the dates as described. The attached workbook has a new sheet with a button to run the macro. Here is the macro code.

Sub SplitDates()

  ' http://www.excelforum.com/excel-programming-vba-macros/892036-finding-date-groups.html
  
    Dim i As Long
    Dim nbrDates As Variant
    Dim r As Long
    Dim rngDates As Range
    Dim rngOutput As Range
    Dim StartDate As Date
    Dim Wks As Worksheet
        
        
        Set rngOutput = Worksheets("Sheet4").Range("A1")
        rngOutput.CurrentRegion.ClearContents
        
        Set Wks = Worksheets("Sheet1")
        
        Set rngDates = Wks.Range("B1")
        Set rngDates = Wks.Range(rngDates, Wks.Cells(Rows.Count, "B").End(xlUp))
        
        For Each Cell In rngDates
            
            If Not IsEmpty(Cell) Then
                Set rngDates = Wks.Range(Cell, Wks.Cells(Cell.Row, Columns.Count).End(xlToLeft))
                nbrDates = rngDates.Value
            
                If TypeName(nbrDates) = "Variant()" Then
                    StartDate = CDate(nbrDates(1, 1))
            
                    For i = 1 To UBound(nbrDates, 2) - 1
                        If nbrDates(1, i + 1) - nbrDates(1, i) <> 1 Then
                            rngOutput.Offset(r, 0).Value = StartDate & " to " & CDate(nbrDates(1, i))
                            r = r + 1
                            StartDate = CDate(nbrDates(1, i + 1))
                            i = i + 1
                        End If
                    Next i
            
                    rngOutput.Offset(r, 0).Value = StartDate & " to " & CDate(nbrDates(1, i))
                    r = r + 2
                End If
                
            End If
           
        Next Cell
           
End Sub

**OAM** · 01-24-2013, 07:23 PM

Leith Ross, the code works great and as I asked for! However, I left out a critical piece of information (I bet that is the first time you ever heard that) and I apologize for that but in column A there are names that go along with each the date ranges. Is there a way to associate the name on the data sheet in column A1 with the dates on the data sheet that start at column B1 and the name in column A2 with the dates that start in column B2, etc..?

Again, I apologize for not letting you know but I was so engrossed in getting the dates sorted that I forgot to associate them to the names. The code works great and thank you for that!

Sincerely

**AB33** · 01-24-2013, 04:33 AM

OAM,
Okay, I left out "to" from row 1, have now amended the code no 6. I do not think my code is right for this task. I thought there is a pattern to your data. I probably could not see it. For e.g in row 1 sheet 1. You have 7 days gab between the dates and suddenly in Aug, it jumps to 14 days.
I think Leith has got it

**Leith Ross** · 01-24-2013, 07:31 PM

Hello OAm,

Since I don't see any names on any of the worksheets in the workbook you posted, I must assume you have a more up to date workbook. Post that one and I will make the changes needed to the macro.

**Leith Ross** · 01-24-2013, 09:45 PM

Hello OAM,

I rewrote the macro to add the names from column "A" and also decreased the running time for the macro. Here is the new macro code. This has been added to the attached workbook.

Sub SplitDates()

  ' Revised: January, 24, 2013
  ' http://www.excelforum.com/excel-programming-vba-macros/892036-finding-date-groups.html
  
    Dim Cell As Range
    Dim Data As Variant
    Dim i As Long
    Dim nbrDates As Variant
    Dim r As Long
    Dim rngDates As Range
    Dim rngOutput As Range
    Dim StartDate As Date
    Dim Wks As Worksheet
        
        ReDim Data(1 To 2, 1 To 1)
        
        Set rngOutput = Worksheets("Sheet4").Range("A1")
        rngOutput.Parent.UsedRange.ClearContents
        
        Set Wks = Worksheets("Sheet1")
        
        Set rngDates = Wks.Range("B1")
        Set rngDates = Wks.Range(rngDates, Wks.Cells(Rows.Count, "B").End(xlUp))
        
        For Each Cell In rngDates
            
            If Not IsEmpty(Cell) Then
                Set rngDates = Wks.Range(Cell, Wks.Cells(Cell.Row, Columns.Count).End(xlToLeft))
                nbrDates = rngDates.Value
            
                If TypeName(nbrDates) = "Variant()" Then
                    StartDate = CDate(nbrDates(1, 1))
            
                    For i = 1 To UBound(nbrDates, 2) - 1
                        If nbrDates(1, i + 1) - nbrDates(1, i) <> 1 Then
                            r = r + 1
                            ReDim Preserve Data(1 To 2, 1 To r)
                            
                            Data(1, r) = Cell.Offset(0, -1)
                            Data(2, r) = StartDate & " to " & CDate(nbrDates(1, i))
                            
                            StartDate = CDate(nbrDates(1, i + 1))
                            i = i + 1
                        End If
                    Next i
            
                    r = r + 2
                    ReDim Preserve Data(1 To 2, 1 To r)
                    
                    Data(1, r - 1) = Cell.Offset(0, -1)
                    Data(2, r - 1) = StartDate & " to " & CDate(nbrDates(1, i))
                End If
                
            End If
           
        Next Cell
        
        Data = Application.Transpose(Data)
        
        rngOutput.Resize(UBound(Data), 2).Value = Data
           
End Sub

**OAM** · 01-24-2013, 11:47 PM

Perfect!! The macro works Great!

[SOLVED]

Finding date groups

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Re: Finding date groups

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions