Inconsistent CountIF results in VBA Macro

Gojira

New Member
Joined
Nov 7, 2017
Messages
17
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:

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
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

Watch MrExcel Video

Forum statistics

Threads
1,127,172
Messages
5,623,178
Members
415,955
Latest member
Footballtend

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top