Skip to content

Instantly share code, notes, and snippets.

Show Gist options
  • Save danwagnerco/9efb125b71706cd5bd75a45a8867e534 to your computer and use it in GitHub Desktop.
Save danwagnerco/9efb125b71706cd5bd75a45a8867e534 to your computer and use it in GitHub Desktop.
This macro prompts you to select a date range then copies the rows in that range to an already-existing worksheet
Option Explicit
'This subroutine prompts the user to select dates
'
'Code already written and described here:
'http://danwagner.co/how-to-copy-data-to-a-new-workbook-based-on-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 AddToDestinationWorksheet(strStart, strEnd)
End Sub
'This subroutine creates adds the filtered data from Sheet1
'to a previously-existing destination Worksheet (called "Destination" here)
Public Sub AddToDestinationWorksheet(StartDate As String, EndDate As String)
Dim wksData As Worksheet, wksTarget As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long, _
lngDestinationLastRow As Long, lngDestinationFirstCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
Dim varFiltered As Variant
'Set references up-front
Set wksTarget = ThisWorkbook.Worksheets("Destination")
Set wksData = ThisWorkbook.Worksheets("Sheet1")
lngDateCol = 8 '<~ we know dates are in column H
'Identify the full data range on Sheet1 (our data sheet) by finding
'the last row and last column
lngLastRow = LastOccupiedRowNum(wksData) '<~ straight from VBA Toolbelt!
lngLastCol = LastOccupiedColNum(wksData) '<~ straight from VBA Toolbelt!
With wksData
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
End With
'Apply a filter to the full range we just assigned to get rows
'that are in-between the start and end dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'If the resulting range contains only 1 row, that means we filtered
'everything out! Check for this situation, catch it and exit
If wksData.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "Oops! Those dates filter out all data!"
'Clear the autofilter safely and exit sub
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
Exit Sub
Else '<~ otherwise we're all good!
'Store ONLY the visible cells (and skipping the header row), which
'match the specified date range
Set rngResult = .Offset(1, 0) _
.Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
'Identify the last row on the destination sheet
lngDestinationLastRow = LastOccupiedRowNum(wksTarget) '<~ <3 u VBA Toolbelt
'Identify the first column on the destination sheet:
'
'If the last row in column A is empty, execute an xlRight from
'there to find the first-occupied column
If wksTarget.Range("A" & lngDestinationLastRow).Value = vbNullString Then
lngDestinationFirstCol = wksTarget _
.Range("A" & lngDestinationLastRow) _
.End(xlToRight) _
.Column
Else '<~ otherwise, the data starts in column A (i.e. 1)
lngDestinationFirstCol = 1
End If
'Now that we know our last row and first column, setting the target is a snap!
Set rngTarget = wksTarget.Cells(lngDestinationLastRow + 1, lngDestinationFirstCol)
'Append (i.e. copy to the bottom of the data range) the filtered
'results to the Destination sheet
rngResult.Copy Destination:=rngTarget
End If
End With
'Clear the autofilter safely
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
'Holler at the user, our macro is done!
MsgBox "Data transferred!"
End Sub
'The functions below are pulled straight from the VBA Toolbelt,
'which you're using -- right? This kind of boilerplate code is what
'makes the VBA Toolbelt so useful! Download it here:
'
'http://danwagner.co/vba-toolbelt/
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment