Copy Cells into an existing tab based on a Date

[deducki]

Hey guys!
I'm trying to create a summary of action tab in a workbook to track several projects. On each tab there are actions, and a complete by date for each action. I want to pull in to a master summary tab any actions that are upcoming in the next 7 business days.
What needs to happen in the code I'm looking for is as follows:

1. Find any date in the next 7 business days
2. Copy that date to a cell in a master tab in the same file
3. In a cell to the left of the date found above, copy the action that is associated with that date
4. In a cell to the left of the action copy the tab name (this is the project name- also store in a cell on the tab

I need this to run on 10+ tabs and pull all actions into the master tab. Each tab essentially looks like this
[TABLE="class: grid, width: 250, align: left"]
<tbody>[TR]
[TD]Project:[/TD]
[TD]Example 1[/TD]
[/TR]
[TR]
[TD]Action[/TD]
[TD]Need By Date[/TD]
[/TR]
[TR]
[TD]Finish[/TD]
[TD]12/01/14[/TD]
[/TR]
[TR]
[TD]Action 5[/TD]
[TD]11/22/14[/TD]
[/TR]
[TR]
[TD]Action 4[/TD]
[TD]11/19/14[/TD]
[/TR]
[TR]
[TD]Action 3[/TD]
[TD]11/16/14[/TD]
[/TR]
[TR]
[TD]Action 2[/TD]
[TD]11/12/14[/TD]
[/TR]
[TR]
[TD]Action 1[/TD]
[TD]11/06/14[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 250, align: left"]
<tbody>[TR]
[TD]Project:[/TD]
[TD]Example 2[/TD]
[/TR]
[TR]
[TD]Action[/TD]
[TD]Need By Date[/TD]
[/TR]
[TR]
[TD]Finish[/TD]
[TD]12/28/14[/TD]
[/TR]
[TR]
[TD]Action 5[/TD]
[TD]12/21/14[/TD]
[/TR]
[TR]
[TD]Action 4[/TD]
[TD]12/12/14[/TD]
[/TR]
[TR]
[TD]Action 3[/TD]
[TD]12/1/14[/TD]
[/TR]
[TR]
[TD]Action 2[/TD]
[TD]11/19/14[/TD]
[/TR]
[TR]
[TD]Action 1[/TD]
[TD]11/14[/TD]
[/TR]
</tbody>[/TABLE]













So what I would want to show up on the master tab would be something like this:
[TABLE="class: grid, width: 250, align: left"]
<tbody>[TR]
[TD]Project:[/TD]
[TD]Action[/TD]
[TD]Need By Date[/TD]
[/TR]
[TR]
[TD]Example 1[/TD]
[TD]Action 3[/TD]
[TD]11/16/14[/TD]
[/TR]
[TR]
[TD]Example 1[/TD]
[TD]Action 4[/TD]
[TD]11/19/14[/TD]
[/TR]
[TR]
[TD]Example 2[/TD]
[TD]Action 1[/TD]
[TD]11/14[/TD]
[/TR]
[TR]
[TD]Example 2[/TD]
[TD]Action 2[/TD]
[TD]11/19/14[/TD]
[/TR]
</tbody>[/TABLE]









It's a big one... any ideas? I'm borderline VBA illiterate but I know other coding languages. Please explain in steps what your code does and I can follow it easily

 

[Warship]

Welcome.
Try:

Sub UpdateProjectMaster()
    Dim maxDate As Date, s As Integer
    Dim srchRng As Range, c As Range
    Dim nextRow As Long, lastRow As Long
    
    Application.ScreenUpdating = False
    maxDate = WorksheetFunction.WorkDay(Date, 7)
    
'   change following s values to suite. project sheets must be consecutive
    For s = 2 To 3 'this is the index of the project sheets, e.g. here it is 2nd & 3rd sheet
    
        lastRow = Sheets(s).Cells(Rows.Count, "B").End(xlUp).Row
        Set srchRng = Sheets(s).Range("B3:B" & lastRow)
        For Each c In srchRng
            If c > Date And c <= maxDate Then
                With Sheets("master")
                    nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(nextRow, "A") = Sheets(s).Name
                    .Cells(nextRow, "B") = c.Offset(, -1)
                    .Cells(nextRow, "C") = Format(c, "m/d/yyyy")
                End With
            End If
        Next c
    Next s
End Sub

 

[deducki]

Thanks! I'm super appreciative!
Does this update based on the system clock, so that things will fall off and show up new every day?
I am thinking that perhaps it would be useful to make the macro look at a cell that is set to a date that can be set by whomever opens it and the macro can be kicked off using a button. And perhaps to set the number of days to look forward to look at a cell value?

Welcome.
Try:

Sub UpdateProjectMaster()
    Dim maxDate As Date, s As Integer
    Dim srchRng As Range, c As Range
    Dim nextRow As Long, lastRow As Long
    
    Application.ScreenUpdating = False
    maxDate = WorksheetFunction.WorkDay(Date, 7)
    
'   change following s values to suite. project sheets must be consecutive
    For s = 2 To 3 'this is the index of the project sheets, e.g. here it is 2nd & 3rd sheet
    
        lastRow = Sheets(s).Cells(Rows.Count, "B").End(xlUp).Row
        Set srchRng = Sheets(s).Range("B3:B" & lastRow)
        For Each c In srchRng
            If c > Date And c <= maxDate Then
                With Sheets("master")
                    nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(nextRow, "A") = Sheets(s).Name
                    .Cells(nextRow, "B") = c.Offset(, -1)
                    .Cells(nextRow, "C") = Format(c, "m/d/yyyy")
                End With
            End If
        Next c
    Next s
End Sub

 

[Warship]

Sub UpdateProjectMaster()
    Dim maxDate As Date, minDate As Date, s As Integer
    Dim srchRng As Range, srchDay As Integer, c As Range
    Dim nextRow As Long, lastRow As Long
    Dim minRng As Range, dayRng As Range
    
    Application.ScreenUpdating = False
    
    Set minRng = Sheets(5).Range("A1")  'start date. change range to suite
    If IsDate(minRng) Then
        minDate = minRng
    Else
        MsgBox "invalid start date"
        Exit Sub
    End If
    
    Set dayRng = Sheets(5).Range("A2")  'num of biz days change range to suite
    If IsNumeric(dayRng) Then
        srchDay = dayRng
    Else
        MsgBox "invalid day"
        Exit Sub
    End If
    
    maxDate = WorksheetFunction.WorkDay(minDate, srchDay)
    
    If MsgBox("Update master from " & minDate & " to " & _
            maxDate & "?", vbYesNo, "Confirm Update") = vbNo Then Exit Sub
    
'   change following s values to suite. project sheets must be consecutive
    For s = 2 To 3 'this is the index of the project sheets, e.g. here it is 2nd & 3rd sheet
    
        lastRow = Sheets(s).Cells(Rows.Count, "B").End(xlUp).Row
        Set srchRng = Sheets(s).Range("B3:B" & lastRow)
        For Each c In srchRng
            If c >= minDate And c <= maxDate Then
                With Sheets("master")
                    nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(nextRow, "A") = Sheets(s).Name
                    .Cells(nextRow, "B") = c.Offset(, -1)
                    .Cells(nextRow, "C") = Format(c, "m/d/yyyy")
                End With
            End If
        Next c
    Next s
    Set minRng = Nothing  'releasing ram
    Set dayRng = Nothing
    Set srchRng = Nothing
End Sub

 

[Warship]

Thanks! I'm super appreciative!

My pleasure.

Does this update based on the system clock, so that things will fall off and show up new every day?

Yes, 1st version did.

I am thinking that perhaps it would be useful to make the macro look at a cell that is set to a date that can be set by whomever opens it... ...perhaps to set the number of days to look forward to look at a cell value?

Done.

...the macro can be kicked off using a button.

Let me know if you need assistance.

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Don't use 2nd ver.

This version avoids having to update ‘s’ values as your projects come and go.
It also eliminates the need for consecutive project sheets.

For the project sheet to be searched it must meet 2 criteria.
A1 must contain “Project:” and B1 must be the same as the sheet’s name, as per the line:

If s.Range("A1") = "Project:" And s.Range("B1") = s.Name Then

As projects complete, changing A1 or B1 will avoid unnecessary “past” searches, unless of course you are looking for historical data.

After you set the ranges for minRng & dayRng you shouldn’t have to ever change your code.
However, if you ever change the master or project sheets layout, the code will fail.

Sub UpdateProjectMaster3()
    Dim maxDate As Date, minDate As Date, s As Worksheet
    Dim srchRng As Range, srchDay As Integer, c As Range
    Dim nextRow As Long, lastRow As Long
    Dim minRng As Range, dayRng As Range
    
    Application.ScreenUpdating = False
    
    Set minRng = Sheets("sw").Range("A1")  'change sheet name & range to suite
    If IsDate(minRng) Then
        minDate = minRng
    Else
        MsgBox "invalid start date"
        Exit Sub
    End If
    
    Set dayRng = Sheets("sw").Range("A2")  'change sheet name & range to suite
    If IsNumeric(dayRng) Then
        srchDay = dayRng
    Else
        MsgBox "invalid day"
        Exit Sub
    End If
    
    maxDate = WorksheetFunction.WorkDay(minDate, srchDay)
    
    If MsgBox("Update master from " & minDate & " to " & _
            maxDate & "?", vbYesNo, "Confirm Update") = vbNo Then Exit Sub
    
    For Each s In ThisWorkbook.Sheets
        If s.Range("A1") = "Project:" And s.Range("B1") = s.Name Then
            lastRow = s.Cells(Rows.Count, "B").End(xlUp).Row
            Set srchRng = s.Range("B3:B" & lastRow)
            For Each c In srchRng
                If c >= minDate And c <= maxDate Then
                    With Sheets("master")
                        nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                        .Cells(nextRow, "A") = s.Name
                        .Cells(nextRow, "B") = c.Offset(, -1)
                        .Cells(nextRow, "C") = Format(c, "m/d/yyyy")
                    End With
                End If
            Next c
        End If
    Next s
    Set minRng = Nothing  'releasing memory
    Set dayRng = Nothing
    Set srchRng = Nothing
End Sub

 

[deducki]

I got the button working and all - I would like the macro to start with clearing the contents of cells A2:C40 before retrieving additional data. I have tried a couple lines of code that I am familiar with, but they seem to just be skipped over!

 

[Warship]

Are you sure it will always be A2:C40 ?
Doesn't this Range change depending previous results?

Sub UpdateProjectMaster4()
    Dim maxDate As Date, minDate As Date, s As Worksheet
    Dim srchRng As Range, srchDay As Integer, c As Range
    Dim nextRow As Long, lastRow As Long
    Dim minRng As Range, dayRng As Range
    Dim mastHdr As Variant
    
    Application.ScreenUpdating = False
    
    mastHdr = Array("Project:", "Action", "Need By Date")
    
    Set minRng = Sheets("sw").Range("A1")  'change sheet name & range to suite
    If IsDate(minRng) Then
        minDate = minRng
    Else
        MsgBox "invalid start date"
        Exit Sub
    End If
    
    Set dayRng = Sheets("sw").Range("A2")  'change sheet name & range to suite
    If IsNumeric(dayRng) Then
        srchDay = dayRng
    Else
        MsgBox "invalid day"
        Exit Sub
    End If
    
    maxDate = WorksheetFunction.WorkDay(minDate, srchDay)
    
    If MsgBox("Update master from " & minDate & " to " & _
            maxDate & "?", vbYesNo, "Confirm Update") = vbNo Then Exit Sub
            
'   to reset master
    With Sheets("master")
        .Cells.Clear
        .Cells(1, 1).Resize(, UBound(mastHdr) + 1) = mastHdr
    End With
    
'   Sheets("master").Range("A2:C40").Clear
    
    For Each s In ThisWorkbook.Sheets
        If s.Range("A1") = "Project:" And s.Range("B1") = s.Name Then
            lastRow = s.Cells(Rows.Count, "B").End(xlUp).Row
            Set srchRng = s.Range("B3:B" & lastRow)
            For Each c In srchRng
                If c >= minDate And c <= maxDate Then
                    With Sheets("master")
                        nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                        .Cells(nextRow, "A") = s.Name
                        .Cells(nextRow, "B") = c.Offset(, -1)
                        .Cells(nextRow, "C") = Format(c, "m/d/yyyy")
                    End With
                End If
            Next c
        End If
    Next s
    Set minRng = Nothing  'releasing memory
    Set dayRng = Nothing
    Set srchRng = Nothing
End Sub

 

[deducki]

Correct, I was just grabbing a range- I simply don't think we'll have more than 40 rows of actions coming up at once is all. Does the code you gave there clear all cells? I wouldn't want all the cells cleared because there a various headers that are being used, and the cells that the macro is reading for date and # of days forward to look are in that sheet as well so I suppose ideally we could clear the cells in columns A-C starting at row 2...

 

[Warship]

It's easier to just clear columns and replace the hearders.

'   to reset master
    With Sheets("master")
        .Range("A:C").Clear
        .Cells(1, 1).Resize(, UBound(mastHdr) + 1) = mastHdr
    End With

 

[Warship]

btw... Clear does not preserve cell formatting.
to preserve formatting use ClearContents