Skip to content

Instantly share code, notes, and snippets.

@danwagnerco
Last active July 5, 2020 17:12
Show Gist options
  • Save danwagnerco/c8448a631abadc3cbc79 to your computer and use it in GitHub Desktop.
Save danwagnerco/c8448a631abadc3cbc79 to your computer and use it in GitHub Desktop.
This script creates a new workbook containing ONLY data between the input dates
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.Copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
@danwagnerco
Copy link
Author

Hi @ritviks95 + @MedYosri + @chemichemi I have written a tutorial and recorded a Youtube screencast describing how to use this code to copy data based on dates here and here:

https://danwagner.co/how-to-copy-data-to-a-new-workbook-based-on-dates/

https://danwagner.co/how-to-copy-data-based-on-dates-part-1-a-new-worksheet/

Please ask me any questions by email (included in the tutorials) or via YouTube comments as I do not check gists here. Thanks! -Dan

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment