Created
April 8, 2016 09:32
-
-
Save danwagnerco/77c468c66b9364125b45cc0057b5af0f to your computer and use it in GitHub Desktop.
This script has some repetition, making it a perfect candidate for extracting functionality... Something like 'ClearAllFilters'!
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
'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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment