Last active
July 5, 2020 17:12
-
-
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
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
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