Andresleo47
Board Regular
- Joined
- Oct 29, 2008
- Messages
- 132
Hi Dear Community, I am trying to build a macro that Filters by date all the months before the month we're in. For example, we're in September 2022. I want to filter by date all the dates before August 2022 and then I want to delete those rows.
This is my code so far, and the Sub I'm talking about is the one called Sub FilterDates()
Thanks,
This is my code so far, and the Sub I'm talking about is the one called Sub FilterDates()
Thanks,
VBA Code:
Sub Path1()
With Application.FileDialog(msoFileDialogFilePicker)
If .Show Then Sheets("Import Files").TextBox1.Text = .SelectedItems(1)
End With
End Sub
Sub Path2()
With Application.FileDialog(msoFileDialogFilePicker)
If .Show Then Sheets("Import Files").TextBox2.Text = .SelectedItems(1)
End With
End Sub
Sub Path3()
With Application.FileDialog(msoFileDialogFilePicker)
If .Show Then Sheets("Import Files").TextBox3.Text = .SelectedItems(1)
End With
End Sub
Private Sub CommandButton1_Click()
'Code done by: Andres Veloza for HCM Works!
'
Dim ClosedWorkbookSheetName As String
Dim FileExtention As String
Dim NewWorkbookName As String
Dim SheetWithTextBoxes As String
Dim ClosedSourceWorkbook As Workbook
'
FileExtention = ".xlsx" ' <--- Set this to the file extention of workbook to be created
NewWorkbookName = "ThisWeek" ' <--- Set this to the name of the workbook to be created
ClosedWorkbookSheetName = "report" ' <--- Set this to the sheet name in the closed workbook
SheetWithTextBoxes = "Import Files" ' <--- Set this to the sheet name that contains the TextBoxes
'
Workbooks.Add.SaveAs Filename:=NewWorkbookName & FileExtention ' Create/Name/save New Workbook
ThisWorkbook.Activate ' Reactivate this workbook
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Set ClosedSourceWorkbook = Workbooks.Open(Sheets(SheetWithTextBoxes).TextBox3.Value) ' Get value from TextBox to open the source file
'
' Copy sheet to beginning of the newly created workbook
ClosedSourceWorkbook.Sheets(ClosedWorkbookSheetName).Copy Before:=Workbooks(NewWorkbookName & FileExtention).Sheets(1)
ClosedSourceWorkbook.Close SaveChanges:=False ' Close the source workbook
'
'
ThisWorkbook.Activate ' Reactivate this workbook
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Set ClosedSourceWorkbook = Workbooks.Open(Sheets(SheetWithTextBoxes).TextBox2.Value) ' Get value from TextBox to open the source file
'
' Copy sheet to beginning of the newly created workbook
ClosedSourceWorkbook.Sheets(ClosedWorkbookSheetName).Copy Before:=Workbooks(NewWorkbookName & FileExtention).Sheets(1)
ClosedSourceWorkbook.Close SaveChanges:=False ' Close the source workbook
'
ThisWorkbook.Activate ' Reactivate this workbook
'
Set ClosedSourceWorkbook = Workbooks.Open(Sheets(SheetWithTextBoxes).TextBox1.Value) ' Get value from TextBox to open the source file
'
' Copy sheet to beginning of the newly created workbook
ClosedSourceWorkbook.Sheets(ClosedWorkbookSheetName).Copy Before:=Workbooks(NewWorkbookName & FileExtention).Sheets(1)
ClosedSourceWorkbook.Close SaveChanges:=False ' Close the source workbook
'
Application.DisplayAlerts = False ' Turn off DisplayAlerts to avoid sheet deletion warning
Sheets("Sheet1").Delete ' Delete Sheet1 from the newly created workbook
Application.DisplayAlerts = True ' Turn DisplayAlerts back on
'
' ActiveWorkbook.Close True ' Save newly created file and close
ActiveWorkbook.Save
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'End
Worksheets("report (2)").Activate
Range("A1").EntireRow.Delete
Call InsertPivotTable
End Sub
Sub InsertPivotTable()
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim lastRow As Long
Dim LastCol As Long
'Insert a New Blank Worksheet
On Error Resume Next
Worksheets("PivotTable").Delete
On Error GoTo 0
Application.DisplayAlerts = False
'Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("report (2)")
lastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(lastRow, LastCol)
'Define Pivot Cache
Set PTable = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="PivotTable")
'Insert Blank Pivot Table
'Set PTable = PCache.CreatePivotTable _
'(TableDestination:=PSheet.Cells(0, 0), TableName:="PivotTable")
'Insert Row Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Work Order ID")
.Orientation = xlRowField
.Position = 1
End With
'Insert Data Field
With ActiveSheet.PivotTables("PivotTable").PivotFields("Total Approved Billable Hours")
.Orientation = xlDataField
.Position = 1
.Function = xlSum
.NumberFormat = "#,##0"
.Name = "Total Approved Billable Hours "
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Spend to Date")
.Orientation = xlDataField
.Position = 2
.Function = xlSum
.NumberFormat = "#,##0"
.Name = "Spend to Date "
End With
Worksheets("report (3)").Activate
Call ChangeFirstRow
End Sub
Sub ChangeFirstRow() 'This code is to put the right format in Row 1
Cells(1, 1).Value = "Master Worker Record ID"
Cells(1, 2).Value = "Job Posting ID"
Cells(1, 3).Value = "Work Order ID"
Cells(1, 4).Value = "Worker"
Cells(1, 5).Value = "Legal Entity"
Cells(1, 6).Value = "Cost Center"
Cells(1, 7).Value = "Work Order Status"
Cells(1, 8).Value = "Supplier"
Cells(1, 9).Value = "Job Posting Title"
Cells(1, 10).Value = "Real Start Date"
Cells(1, 11).Value = "Work Order Start Date"
Cells(1, 12).Value = "Worker Start Date"
Cells(1, 13).Value = "First Work Order End Date"
Cells(1, 14).Value = "Latest Work Order End Date"
Cells(1, 15).Value = "Spend to Date"
Cells(1, 16).Value = "Hours per Week"
Cells(1, 17).Value = "Cumulative Committed Spend"
Cells(1, 18).Value = "Total Approved Billable Hours"
Cells(1, 19).Value = "Total Estimated Hours"
Cells(1, 20).Value = "Business Unit"
Cells(1, 21).Value = "Hiring Manager"
Cells(1, 22).Value = "Work Order Owner Username"
Cells(1, 23).Value = "Invoice Approver"
Cells(1, 24).Value = "Current Bill Rate [ST/Hr]"
Cells(1, 25).Value = "Site"
Cells(1, 26).Value = "Worker Status"
Cells(1, 27).Value = "Revision #"
Cells(1, 28).Value = "Status"
Cells(1, 29).Value = "Worker Email"
Range("A1:AC1").Font.Bold = True
Range("A1:AC1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Range("A1").Font.Size = 9
Call ShiftColumns
End Sub
Sub ShiftColumns()
Dim Fnd As Range 'This code moves the "Worker" column
Set Fnd = Range("2:2").Find("Worker", , , xlWhole, , xlNext, False, , False)
If Not Fnd Is Nothing Then
Range(Fnd.Offset(, -1), Cells(Rows.Count, Fnd.Offset(, -1).Column)).Delete xlToLeft
End If
Dim Fnd2 As Range 'This code moves the "Work Order Status" column
Set Fnd2 = Range("2:2").Find("Work Order Status", , , xlWhole, , xlNext, False, , False)
If Not Fnd2 Is Nothing Then
Range(Fnd2, Cells(Rows.Count, Fnd2.Column)).Resize(, 2).Insert xlToRight
End If
Dim Fnd3 As Range, Fnd4 As Range 'This code moves the "Legal Entity" column
Set Fnd3 = Range("2:2").Find("Legal Entity", , , xlWhole, , xlNext, False, , False)
Set Fnd4 = Range("1:1").Find("Legal Entity", , , xlWhole, , xlNext, False, , False)
If Not Fnd3 Is Nothing And Not Fnd4 Is Nothing Then
Range(Fnd3, Cells(Rows.Count, Fnd3.Column)).Cut Fnd4.Offset(1)
End If
Dim Fnd5 As Range, Fnd6 As Range 'This code moves the "Cost Center" column
Set Fnd5 = Range("2:2").Find("Cost Center", , , xlWhole, , xlNext, False, , False)
Set Fnd6 = Range("1:1").Find("Cost Center", , , xlWhole, , xlNext, False, , False)
If Not Fnd5 Is Nothing And Not Fnd6 Is Nothing Then
Range(Fnd5, Cells(Rows.Count, Fnd5.Column)).Cut Fnd6.Offset(1)
End If
Dim Fnd7 As Range
Set Fnd7 = Range("1:1").Find("Hiring Manager", , , xlWhole, , xlNext, False, , False)
If Not Fnd7 Is Nothing Then
Fnd7.Offset(1) = "Hiring Manager"
End If
Dim Fnd8 As Range
Set Fnd8 = Range("1:1").Find("Invoice Approver", , , xlWhole, , xlNext, False, , False)
If Not Fnd8 Is Nothing Then
Fnd8.Offset(1) = "Invoice Approver"
End If
Call PopulateHMandIA_v02
End Sub
Sub PopulateHMandIA_v02()
Dim ws As Worksheet
Dim wb As Workbook
Dim UserHdg As Range
Dim rngUserName As Range
Dim MyLookup As Range
Dim wbApprov As Workbook
Dim wsApprovers As Worksheet
Dim HM_Hdg As Range
Dim rngHM As Range
Dim lastRow As Long
Set wb = Workbooks("ThisWeek.xlsx")
Set ws = wb.Worksheets("report (3)")
Set wbApprov = ThisWorkbook '<--- approvers list in THIS workbook
Set wsApprovers = wbApprov.Worksheets("Approvers")
With wsApprovers
Set MyLookup = .Range("A1:C" & .Cells(Rows.Count, "A").End(xlUp).Row) ' XXX Added Column C
End With
Set UserHdg = ws.Range("1:1").Find("Work Order Owner Username", , , xlWhole, , xlNext, False, , False)
If Not UserHdg Is Nothing Then
Set rngUserName = UserHdg.Offset(2)
lastRow = ws.Cells(Rows.Count, rngUserName.Column).End(xlUp).Row
Else
Exit Sub
End If
Set HM_Hdg = ws.Range("1:1").Find("Hiring Manager", , , xlWhole, , xlNext, False, , False)
With ws
Set rngHM = .Range(HM_Hdg.Offset(2), .Cells(lastRow, HM_Hdg.Column))
End With
rngHM.FormulaR1C1 = "=VLookup(" & "RC" & rngUserName.Column & "," & MyLookup.Address(1, 1, 0, 1) & ", 2, False)"
rngHM.Value = rngHM.Value '<--- Removes formulas - comment out if you want to keep them
With wsApprovers
Set MyLookup = .Range("A1:C" & .Cells(Rows.Count, "A").End(xlUp).Row)
End With
' XXX Added look for Invoice Approver column
Set HM_Hdg = ws.Range("1:1").Find("Invoice Approver", , , xlWhole, , xlNext, False, , False)
With ws
Set rngHM = .Range(HM_Hdg.Offset(2), .Cells(lastRow, HM_Hdg.Column))
End With
rngHM.FormulaR1C1 = "=VLookup(" & "RC" & rngUserName.Column & "," & MyLookup.Address(1, 1, 0, 1) & ", 3, False)"
rngHM.Value = rngHM.Value '<--- Removes formulas - comment out if you want to keep them
HM_Hdg.Offset(1).EntireRow.Delete
Call PopulateWorkerEmail
End Sub
Sub PopulateWorkerEmail()
Worksheets("report (3)").Select
Dim Formula As Long
Range("AC2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-26],report!C[-26]:C,27,0)"
Range("AC2").Select
Selection.AutoFill Destination:=Range("AC2:AC658")
Range("N1").Select
Worksheets("report (3)").Range("A1").AutoFilter
Call FilterDates
End Sub
Sub FilterDates()
Current_Date = Format(Date, "mm/yyyy")
Range("A4:A10").AutoFilter
Range("A4:A10").AutoFilter Field:=1, Criteria1:=">=" & Current_Date, _
Operator:=xlAnd, Criteria2:="<" & Current_Date + 1
'Call ChangeTabsNames
End Sub
Sub ChangeTabsNames()
Sheets("report").Name = "Last Week's Report"
Sheets("report (2)").Name = "Spend by Contractor"
Sheets("report (3)").Name = "This Week's Report"
'Call File_Saver
End Sub
Sub File_Saver()
' Some variables
Dim IntialName As String
Dim fileSaveName As Variant
'A catch to give a default name of what's in cell A1
InitialName = Range("A1")
'Automatic generation of month day, year file name, 4 m's will give the full month, 1 d will give 2 instead of 02 and yy will give you a 2 digit year. This includes spaces and a comma.
YourFile = Format(Date, "yyyy") & "-" & Format(Date, "mm") & "-" & Format(Date, "dd") & ".xlsx"
'File save dialog opener
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=IntialName & "Active Contractor - Cost Center Legal Entity - " & " " & _
YourFile, fileFilter:="Excel Files (*.xlsx), *.xlsx")
End Sub
