Hi,
I've got a macro that is pulling data in from a daily timesheet file and summarising it into weeks. It's looping through the 'sum' calculation based on the number of weeks there are in the header row, which itself is created based on the timesheet file. The problem is that I'm encountering odd behaviours on a couple of the files that use the macro, but not on others.
For instance there are two files that seem to think that the number of weeks to loop for is 5, whereas it's actually 48.
I've narrowed the problem down (I think) to a single line in the macros (below), which is this one:
Is there a reason why the code is producing the 'wrong' output? Is there a more error proof method of achieving the same result?
There are two macros here. They're called one after the other by another macro that pulls all the timesheet information in from elsewhere and temporarily stores it on a single sheet within this file.
I've got a macro that is pulling data in from a daily timesheet file and summarising it into weeks. It's looping through the 'sum' calculation based on the number of weeks there are in the header row, which itself is created based on the timesheet file. The problem is that I'm encountering odd behaviours on a couple of the files that use the macro, but not on others.
For instance there are two files that seem to think that the number of weeks to loop for is 5, whereas it's actually 48.
I've narrowed the problem down (I think) to a single line in the macros (below), which is this one:
Code:
NumWeeks = Application.CountIf(Rows(1), ">=" & First_Date)Is there a reason why the code is producing the 'wrong' output? Is there a more error proof method of achieving the same result?
There are two macros here. They're called one after the other by another macro that pulls all the timesheet information in from elsewhere and temporarily stores it on a single sheet within this file.
Code:
Sub FilterTimesheet()
Dim First_Date As Date
Dim Last_Date As Date
Dim First_Monday As Date
Dim Dateoffset As Range
Dim Date_Iter As Date
Dim NewHeaders As Range
Dim NumFilteredRows As Long
Dim NumFilteredCol As Long
Dim LR As Long
Dim LC As Long
Dim SearchRange As Range
Dim CopyRange As Range
Dim HeaderRow As Range
Dim i As Integer
Dim j As Integer
Dim fnd As Variant
Dim rplc As Variant
fnd = "="
rplc = "#"
' Go to the Timesheet Data worksheet and find the earliest and latest dates from the header row
Worksheets("Timesheet Data").Activate
Last_Date = Application.WorksheetFunction.Max(Rows(1))
First_Date = Application.WorksheetFunction.Min(Rows(1))
' Do a little error check so we don't go back a week too far
If Weekday(First_Date) = 2 Then
Date_Iter = First_Date
Else
First_Date = First_Date - Weekday(First_Date, 3)
Date_Iter = First_Date
End If
' Create the Filtered Data Worksheet, deleting any previous version to ensure clean data.
' First set variable j to the number of sheets in the work book.
j = Sheets.Count
' Then loop through each worksheet and check if it's called Filtered data. If it is, delete it and end the loop
For i = 1 To j
If Sheets(i).Name = "Filtered Data" Then
Application.DisplayAlerts = False
Sheets("Filtered Data").Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
' And finally create and activate the fresh Filtered Data sheet
Sheets.Add
ActiveSheet.Name = "Filtered Data"
' Set up our Criteria Range for the Advanced Filter later on
Range("A1").Value = "ID"
Range("A2").Value = ThisWorkbook.Sheets("Summary").Range("B1")
' Then set up the header row, using the same fields as the Timesheet Data sheet, also force correct formatting to be sure
Sheets("Timesheet Data").Activate
Rows(1).Copy
Sheets("Filtered Data").Activate
Rows(4).Select
ActiveSheet.Paste
ActiveSheet.Cells.NumberFormat = "General"
Range("L4").Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Set HeaderRow = Selection
With HeaderRow
.NumberFormat = "DD/MM/YYYY"
.Columns.AutoFit
End With
ActiveSheet.Range("4:4").Columns.AutoFit
' Create the working data worksheet, delete any old sheet that was there before for data integrity
' First set variable j to the number of sheets in the work book.
j = Sheets.Count
' Then loop through each worksheet and check if it's called Filtered data. If it is, delete it and end the loop
For i = 1 To j
If Sheets(i).Name = "Weekly Data" Then
Worksheets("Finance Tracker").Activate
Sheets("Finance Tracker").Cells.Replace What:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Application.DisplayAlerts = False
Sheets("Weekly Data").Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
Sheets.Add
ActiveSheet.Name = "Weekly Data"
Worksheets("Finance Tracker").Activate
Sheets("Finance Tracker").Cells.Replace What:=rplc, Replacement:=fnd, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Sheets("Weekly Data").Activate
' Create the headers, need to make sure the Range is correct
Worksheets("Timesheet Data").Range("A1:K1").Copy Destination:=Worksheets("Weekly Data").Range("A1")
' Tell the loop where to begin puttng the weekly dates
Set Dateoffset = Range("L1")
Dateoffset.Select
' Loop through the dates, starting with the first date variable, ending with the last and populate with each weekly date
For Date_Iter = First_Date To Last_Date
Dateoffset.Value = Date_Iter
Set Dateoffset = Dateoffset.Offset(0, 1)
Date_Iter = Date_Iter + 6
Next Date_Iter
' Set the widths of the columns to look nice
ActiveSheet.Cells.NumberFormat = "General"
Range("L1").Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Set HeaderRow = Selection
With HeaderRow
.NumberFormat = "DD/MM/YYYY"
.Columns.AutoFit
End With
Worksheets("Weekly Data").Range("1:1").Columns.AutoFit
Sheets("Timesheet Data").Activate
Range("A1").Select
LR = ActiveCell.End(xlDown).Row
LC = ActiveCell.End(xlToRight).Column
Range(ActiveCell, Cells(LR, LC)).Select
Set SearchRange = Selection
' Go to the filtered data sheet
Sheets("Filtered Data").Activate
Range("A4").Select
LC = ActiveCell.End(xlToRight).Column
Range(ActiveCell, Cells(4, LC)).Select
Set CopyRange = Selection
' Copy in any rows that match the project ID
' Need to change the Ranges here so they are both dynamic and not static. Criteria Range is ok.
Application.CutCopyMode = False
SearchRange.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), _
CopyToRange:=CopyRange, _
Unique:=False
' For every row that's been copied into Sheet1, the first few columns (A:K) are pulled into the Weekly sheet.
' This can be a constant as the number of columns should never change
' First find the number of rows in the timesheet we're looking at at the moment
NumFilteredRows = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
' Second, find the total number of columns, which we can use later
NumFilteredCol = Cells(1, Columns.Count).End(xlToLeft).Column
' Then for each of the rows of data we have, copy the non-time values to paste into the Weekly Data Tab.
Range("A5").Select
Range(Selection, Selection.Offset(NumFilteredRows - 4, 10)).Select
Selection.Copy
' Now activate the data destination tab and paste the selected data into it
Worksheets("Weekly Data").Activate
' And paste the copied data into the Weekly sheet
Range("A2").Activate
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Sub Sum_Days()
' Define variables.
Dim TimeTotal As Double ' Needs to be a double because we're using decimal places
Dim x As Range
Dim y As Range
Dim CriteriaRange As Range
Dim SumRange As Range
Dim Criteria1 As Variant
Dim Criteria2 As Variant
Dim First_Date As Date
Dim Last_Date As Date
Dim DataCell As Range
Dim CellCount As Long
Dim NumWeeks As Long
Dim LastRow As Long
Dim CurrentRow As Long
' First lets find out the First and Last Dates of the entire range of working data
Worksheets("Filtered Data").Activate
Last_Date = Application.WorksheetFunction.Max(Rows(4))
First_Date = Application.WorksheetFunction.Min(Rows(4))
'MsgBox ("First Date = " & First_Date)
' Now we set a Range variable to store the first date
With Worksheets("Filtered Data").Range("4:4")
Set x = .Find(First_Date, LookIn:=xlFormulas)
'Set x = Range("L4")
'MsgBox ("X = " & x.Address)
End With
' Which we then use as the starting point to select the whole range of dates and store it as our Criteria Range for a SumIF
' If this goes wrong, then chances are the cell it's looking for isn't formatted correctly
x.Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
Set CriteriaRange = Selection
' And offset that range by one row to give us the first row of 'Sum Range' data for the SumIF
Set SumRange = CriteriaRange.Offset(1, 0)
SumRange.Select
' Now set up the Criteria for the SumIFS. The first date on both the filtered and weekly tabs should be the same
' So we can just use that as our starting point. First, look for 'First_Date' on the Weekly sheet and set a range
' variable 'y' to be that value.
With Worksheets("Weekly Data").Range("1:1")
Set y = .Find(First_Date, LookIn:=xlFormulas)
'MsgBox ("y = " & y)
End With
' Select the cell we're going to start pasting data into, and while we're at it, find the number of columns containing dates
Worksheets("Weekly Data").Activate
'Range("A1").Select
With Worksheets("Weekly Data").Range("1:1")
Set DataCell = .Find(First_Date, LookIn:=xlFormulas)
'MsgBox ("DataCell = " & DataCell.Address)
Set DataCell = DataCell.Offset(1, 0)
DataCell.Select
NumWeeks = Application.CountIf(Rows(1), ">=" & First_Date)
End With
' We need to know how many rows we are looping through when merging and copying the data from the Filtered to Weekly tabs
LastRow = Range("A" & Rows.Count).End(xlUp).Row
' And we need to set the two criteria for the sumif to match against. They will be the 'First Date', set as a range by
' the 'y' variable, and the following week, for which we offset the cell we found when setting 'y' by 1 column
Criteria1 = y
Criteria2 = y.Offset(0, 1).Value
' And here's the complicated bit. We have a loop within a loop.
' The outside loop (CurrentRow) works down the rows of data we've pulled into the Filtered Data sheet
' The inside loop (CellCount) works along each row doing the sumif statement and populating the weekly time data
' The sumif uses the SumRange and CriteriaRange set earlier on teh Filtered Data tab, and the two Criteria variables set on the weekly tab
' to check if time values are between two dates. Then it sets the current cell to be that sum value and moves on.
For CurrentRow = 2 To LastRow
For CellCount = 1 To NumWeeks
TimeTotal = Application.WorksheetFunction.SumIfs(SumRange, CriteriaRange, ">=" & CLng(Criteria1), CriteriaRange, "<" & CLng(Criteria2))
ActiveCell.Offset(0, CellCount - 1) = TimeTotal
Criteria1 = Criteria1 + 7
Criteria2 = Criteria2 + 7
Next CellCount
' Here, within the first loop we go back to the Filtered Data sheet and move the 'SumRange' down a row
Worksheets("Filtered Data").Activate
'SumRange.Select
Set SumRange = SumRange.Offset(1, 0)
'SumRange.Select
' And here, we move the active cell down a row and reset the two criteria to their starting values so we can work on the new row
Worksheets("Weekly Data").Activate
ActiveCell.Offset(1, 0).Select
Criteria1 = y
Criteria2 = y.Offset(0, 1).Value
Next CurrentRow
ThisWorkbook.Worksheets("Weekly Data").Cells.EntireColumn.AutoFit
' Here we convert the data on the Weekly Data sheet into a table.
Worksheets("Weekly Data").Activate
ActiveSheet.Range("A1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.Names.Add Name:="WeeklyDataRange", RefersTo:=Selection
ActiveSheet.Range("A1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="WeeklyDataNameCol", RefersTo:=Selection
ActiveSheet.Range("A1").Select
ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.Names.Add Name:="WeeklyDataDateRow", RefersTo:=Selection
Sheets("Weekly Data").Visible = False
End Sub
