VBA Noob - Help creating 2 week lookahead

[sparkytech]

I currently have a sheet with an "outage info" table and a start/end date for each outage. I have a '2 Week Lookahead' button on this sheet that runs a macro to copy any rows with outages that fall within the next 2 weeks to an existing worksheet titled '2 Week Look Ahead'. The code currently has an input box for the start/end dates, but I would like it to automatically calculate 2 weeks from this weeks start date. I used some code I found as a starting point. I have tried modifying it... it sort of works, but am stuck. I can't seem to make the macro look at columns C & D for dates, and i am not sure how to automate the 2 week date range. Please forgive the code errors, as this is a work in progress by a total noob. Any help would be greatly appreciated!

Example outage sheet:

RQ	SS	Start	End	Rls	Disp	Type	BP	WO	Sta	Scope	Remarks
435645	23254	2/3/2018	5/1/2019	Y	D	Clr	7587	095677	Sta1	Scope1	Remarks 1
456452	26446	5/20/2018	12/4/2020	N	T	Clr	5678	546784	Sta2	Scope2	Remarks 2

<tbody>
</tbody>

VBA Code for the 2 Week Look Ahead button below:

Sub Copy_Click()

    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range '-- this is used to store the single cell in the For Each loop


    Set shtSrc = Sheets("Outages")
    Set shtDest = Sheets("2 Week Lookahead")


    destRow = 10 'start copying to this row on destination sheet


    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))


    'Look for matching dates in columns D5 to E1000
    Set rng = Application.Intersect(shtSrc.Range("D5:E1000"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
                     
            c.Offset(0, 0).Resize(1, 10).Copy _
                          shtDest.Cells(destRow, 4) 'Copy a 10-cell wide block to the other sheet, paste into Col D on row destRow


            destRow = destRow + 1


        End If
    Next


End Sub

 

[sparkytech]

Update:

I had some success with fixing the copy function - now it copies all of the pertinent cells to the 2 week look ahead sheet. The main problem is that it still isn't copying correctly for some of the rows.

Revised code:

Sub Copy_Click()

    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range '-- this is used to store the single cell in the For Each loop


    Set shtSrc = Sheets("Outages")
    Set shtDest = Sheets("2 Week Lookahead")


    destRow = 10 'start copying to this row on destination sheet


    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))


    'Look for matching dates in columns C5 to D1000
    Set rng = Application.Intersect(shtSrc.Range("C5:D1000"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
                     
            c.Offset(0, -2).Resize(1, 13).Copy _
                          shtDest.Cells(destRow, 1) 'Copy a 10-cell wide block to the other sheet, paste into Col C on row destRow


            destRow = destRow + 1


        End If
    Next


End Sub

 

[sparkytech]

Update #2

I apologize, as I probably didn't describe my problem very well. Persistence pays off, and I finally figured out the code for the automatic 2 week look ahead. The last remaining problem is this:

I create a new outage with the following dates on the "Outages" sheet:
RQ#1 SS#1 Start Date=1/1/2018 End Date=1/2/2018

I run the macro, and it creates/copies (2) entries on the "2 Week Look Ahead" sheet, (1) with the 1/1/2018 date, and one with the 1/2/2018 date (and this one is shifted to the left by one column, if that makes any sense). Since these dates are for the same outage, I only want to copy this row to the "2 Week Look Ahead" sheet once.

Revised VBA:

Sub Copy_Click()    ' Prompt for confirmation before clearing current 2 Week Look Ahead
    Dim varResponse As Variant
    varResponse = MsgBox("Clear the current 2 Week Lookahead and continue?", vbYesNo, "Selection")
    If varResponse <> vbYes Then Exit Sub
    
    ThisWorkbook.Sheets("2 Week Look Ahead").Range("10:1000").Delete xlUp ' Clears 2 Week Look Ahead sheet, rows 10-1000


    ' Set Variables
    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range '-- this is used to store the single cell in the For Each loop


    Set shtSrc = Sheets("Outages") ' Sets "Outages" sheet as source
    Set shtDest = Sheets("2 Week Look Ahead") 'Sets "2 Week Look Ahead" as destination


    destRow = 10 'Start copying to this row on destination sheet


    ' Use 2 week date range from this week's start
        
    startdate = CDate(ThisWorkbook.Sheets("2 Week Look Ahead").Range("G7"))  ' Use this week Sunday date for start date
    enddate = CDate(ThisWorkbook.Sheets("2 Week Look Ahead").Range("I7")) ' Use 2 weeks from Sunday date for end date


    ' Set range to search for dates in 2 week period
    Set rng = Application.Intersect(shtSrc.Range("C5:D1000"), shtSrc.UsedRange)
    
    'Look for matching dates in columns C5 to D1000
    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then ' Does date fall between start and end dates? If Yes, then copy to destination sheet
                     
            c.Offset(0, -2).Resize(1, 12).Copy _
                          shtDest.Cells(destRow, 1) 'Copy a 12 cell wide block to the other sheet, paste into Column A on row destRow


            destRow = destRow + 1


        End If 'Ends search for dates
    Next
    Sheets("2 Week Look Ahead").Activate ' Changes view to 2 Week Look Ahead Sheet
    
    
End Sub

Any ideas? I'm sure my code is kind of sloppy, so any advice would also be appreciated! Thanks in advance!

 

[NoSparks]

Your rng being columns C and D
the For Each c In rng.Cells will be looking at C5 then D5 then C6 then D6 then C7 then D7 and so on.
You'll require different offsets to the column A cell but can avoid that by specifying the column A cell directly...
cells(c.row, 1) or
range("A" & c.row)