Trying to filter by month
This filter is to filter the months (In column 6) on a sheet then copy the result over to another sheet but it won`t filter the first sheet?
Do I need to use a count x to count all filled-in cells in the column or do I need to use the date column (In Column 3) to filter?
Code
Option Explicit
Public Sub PromptUserForInputMonths()
Dim strStart As String, strEnd As String, strPromptMessage As String
Dim wksData As Worksheet
Dim x As Integer
Dim Lastrow As Long
Dim Months As Object
strStart = InputBox("Please enter the Current JobNos.First Month")
Set wksData = ThisWorkbook.Worksheets("TGS JOB RECORD")
Lastrow = wksData.Range("A" & Rows.Count).End(xlUp).Row
Set Months = wksData.Range("F2:F" & Lastrow)
For x = 2 To 6
If Cells(x, 6).Value = 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
Next x
strEnd = InputBox("Please enter the Current JobNos. Last Month")
For x = 2 To 6
If Cells(x, 6).Value = strEnd 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
Next x
Call CreateSubsetWorksheet(strStart, strEnd)
End Sub
Public Sub CreateSubsetWorksheet(StartMonth As String, EndMonth As String)
TurnOff
ThisWorkbook.Worksheets("Current Jobs").Delete
Dim wksData As Worksheet, wksTarget As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range, JobNotDone As Range
Set wksData = ThisWorkbook.Worksheets("TGS JOB RECORD")
lngDateCol = 6
Set JobNotDone = wksData.Range("A2").CurrentRegion
lngLastRow = LastOccupiedRowNum(wksData)
lngLastCol = LastOccupiedColNum(wksData)
With wksData
Set rngFull = wksData.Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
End With
wksData.AutoFilterMode = False
JobNotDone.AutoFilter field:=5, Criteria1:="="
With rngFull
.AutoFilter field:=lngDateCol, _
Criteria1:=">=" & StartMonth, Operator:=xlAnd, Criteria2:="<=" & EndMonth
Set rngResult = .SpecialCells(xlCellTypeVisible)
Set wksTarget = ThisWorkbook.Worksheets.Add
wksTarget.Name = "Current Jobs"
Set rngTarget = wksTarget.Cells(1, 1)
rngResult.Copy Destination:=rngTarget
wksTarget.Columns.AutoFit
Call Body_Name
End With
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
MsgBox "Data transferred!"
TurnOn
End Sub
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
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
Sub TurnOff()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
End Sub
Sub TurnOn()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
