VBA Noob - Help creating 2 week lookahead

sparkytech

Board Regular
Joined
Mar 6, 2018
Messages
96
Office Version
  1. 365
  2. 2019
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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]RQ[/TD]
[TD]SS[/TD]
[TD]Start[/TD]
[TD]End[/TD]
[TD]Rls[/TD]
[TD]Disp[/TD]
[TD]Type[/TD]
[TD]BP[/TD]
[TD]WO[/TD]
[TD]Sta[/TD]
[TD]Scope[/TD]
[TD]Remarks[/TD]
[/TR]
[TR]
[TD]435645[/TD]
[TD]23254[/TD]
[TD]2/3/2018[/TD]
[TD]5/1/2019[/TD]
[TD]Y[/TD]
[TD]D[/TD]
[TD]Clr[/TD]
[TD]7587[/TD]
[TD]095677[/TD]
[TD]Sta1[/TD]
[TD]Scope1[/TD]
[TD]Remarks 1[/TD]
[/TR]
[TR]
[TD]456452[/TD]
[TD]26446[/TD]
[TD]5/20/2018[/TD]
[TD]12/4/2020[/TD]
[TD]N[/TD]
[TD]T[/TD]
[TD]Clr[/TD]
[TD]5678[/TD]
[TD]546784[/TD]
[TD]Sta2[/TD]
[TD]Scope2[/TD]
[TD]Remarks 2[/TD]
[/TR]
</tbody>[/TABLE]


VBA Code for the 2 Week Look Ahead button below:

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 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
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
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:

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
 
Upvote 0
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:

Code:
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!
 
Upvote 0
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)
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,329
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top