VBA counts how many times a value appears in the column if the criteria are met?

advertisements

I have a workbook called report and a workbook called tacker.

In my report workbook in cell B9 i have a number which is 7 in this case.

The number represents a week number.

I am copying values across from my tracker workbook to report workbook, where that row contains the number 7.

Here is my code:

Option Explicit
Sub code3()
MsgBox "This will take upto 2 minutes."

Application.ScreenUpdating = False
Dim WB As Workbook
Dim I As Long
Dim j As Long
Dim Lastrow As Long
Dim WeekNum As Integer

'Clear Data Sheet

On Error GoTo Message

With ThisWorkbook.Worksheets("Data")
    .Rows(2 & ":" & .Rows.Count).ClearContents
End With

On Error Resume Next

Set WB = Workbooks("L.O. Lines Delivery Tracker.xlsm")
On Error GoTo 0
If WB Is Nothing Then 'open workbook if not open
    Set WB = Workbooks.Open("G:\WH DISPO\(3) PROMOTIONS\(18) L.O. Delivery Tracking\L.O. Lines Delivery Tracker.xlsm")
End If

' ======= Edit #2 , also for DEBUG ======
With WB.Worksheets(1)
    Lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row

    j = 2

        For I = 7 To Lastrow

        WeekNum = CInt(Format(.Range("G" & I).Value, "ww", 2) - 1)

        ' === For DEBUG ONLY ===
        Debug.Print CInt(ThisWorkbook.Worksheets(2).Range("B9").Value)
        Debug.Print WeekNum
        Debug.Print CInt(ThisWorkbook.Worksheets(2).Range("D9").Value)
        Debug.Print Year(.Range("G" & I).Value)
        Debug.Print ThisWorkbook.Worksheets(2).Range("B6").Value
        Debug.Print .Range("M" & I).Value

        If CInt(ThisWorkbook.Worksheets(3).Range("B9").Value) = WeekNum Then ' check if Month equals the value in "A1"
            If CInt(ThisWorkbook.Worksheets(3).Range("D9").Value) = Year(.Range("G" & I).Value) Then ' check if Year equals the value in "A2"
            If ThisWorkbook.Worksheets(3).Range("B6").Value = .Range("M" & I).Value Then
                ThisWorkbook.Worksheets("Data").Range("A" & j).Value = .Range("G" & I).Value
                ThisWorkbook.Worksheets("Data").Range("B" & j).Formula = "=WeekNum(A" & j & ",21)"
                ThisWorkbook.Worksheets("Data").Range("C" & j).Value = .Range("L" & I).Value
                ThisWorkbook.Worksheets("Data").Range("D" & j).Value = .Range("D" & I).Value
                ThisWorkbook.Worksheets("Data").Range("E" & j).Value = .Range("E" & I).Value
                ThisWorkbook.Worksheets("Data").Range("F" & j).Value = .Range("F" & I).Value
                ThisWorkbook.Worksheets("Data").Range("g" & j).Value = .Range("p" & I).Value
                ThisWorkbook.Worksheets("Data").Range("H" & j).Value = .Range("H" & I).Value
                ThisWorkbook.Worksheets("Data").Range("I" & j).Value = .Range("I" & I).Value
                ThisWorkbook.Worksheets("Data").Range("J" & j).Value = .Range("J" & I).Value
                ThisWorkbook.Worksheets("Data").Range("k" & j).Value = .Range("Q" & I).Value
                ThisWorkbook.Worksheets("Data").Range("L" & j).Value = .Range("m" & I).Value
                ThisWorkbook.Worksheets("Data").Range("M" & j).Value = .Range("B" & I).Value

                Dim iVal As Integer
                Dim Lastrow2 As Long
                Lastrow2 = .Cells(Rows.Count, "D").End(xlUp).Row
                iVal = Application.WorksheetFunction.CountIf(Range("D" & Lastrow2), .Range("D" & I).Value)
                ThisWorkbook.Worksheets("Data").Range("N" & j).Value = iVal

                j = j + 1
            End If
            End If
        End If
    Next I

End With

Application.Calculation = xlAutomatic
ThisWorkbook.Worksheets("Data").UsedRange.Columns("B:B").Calculate
ThisWorkbook.Worksheets(3).UsedRange.Columns("B:AA").Calculate

On Error GoTo Message
With ThisWorkbook.Worksheets(3) '<--| change "mysheet" to your actual sheet name
    Intersect(.Range(Rows(14), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("G:G")).WrapText = True
    Intersect(.Range(Rows(14), .UsedRange.Rows(.UsedRange.Rows.Count)), .Range("G:G")).EntireRow.AutoFit
End With

End

ThisWorkbook.Worksheets(3).Activate
Application.ScreenUpdating = True

ThisWorkbook.Worksheets(3).EnableFormatConditionsCalculation

Exit Sub
Message:
On Error Resume Next
Exit Sub

End Sub

Here is my problem:

During the copying process, I want to scan column D in my tracker workbook for repeat values.

I am wanting to count the number of times these repeat values occur.

I am trying to do this in this section of my code:

              Dim iVal As Integer
                Dim Lastrow2 As Long
                Lastrow2 = .Cells(Rows.Count, "D").End(xlUp).Row
                iVal = Application.WorksheetFunction.CountIf(Range("D" & Lastrow2), .Range("D" & I).Value)
                ThisWorkbook.Worksheets("Data").Range("N" & j).Value = iVal

It always produces 0 for some reason, even though there are repeat values in my column.

In addition, i also want to add a condition to this code to say count all repeat values if within 4 weeks of the week number in B9 (in my report workbook).

So for example if the report has week '7' in cell B9, then count all repeat values if for week 7, 6, 5 and 4.

Please can someone help me with my code in order to get it to do what i need?


You're only doing a count on only the last row so you need to put Range("D7:

iVal = Application.WorksheetFunction.CountIf(Range("D7:D" & Lastrow2), .Range("D" & I).Value)

Do you really need Lastrow2? can you not use I-1 instead

iVal = Application.WorksheetFunction.CountIf(Range("D7:D" & I-1), .Range("D" & I).Value)

Also, You can use conditional formatting on column D after you've copied the data to highlight all the duplicates.