Message Box showing number of times a certain word followed by a digit occurs first in rows in column

[Ironman]

Hi

Sheet 'Training 1981-1997' Column F2:F6210 contains text, with some rows that start with the word "Day" (without the commas) followed by a space and a number.

I need to cross-check to make sure I haven't skipped or duplicated a number in error. Therefore what I'd be grateful for is some double click event code I can run in any cell in Col G that will return a msgbox that has counted the number of cells in Col F2:F6210 with text beginning with the word "Day" followed by a space and a digit e.g. "Day 123". I've used the 'Find' function to do this so far, but it'll be faster just to double click.

Many thanks!

 

[mumps]

Delete all the existing BeforeDoubleClick macros and test this one:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.CountLarge > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Dim lRow As Long, v As Variant, i As Long, x As Long
    lRow = Range("F" & Rows.Count).End(xlUp).Row
    If Intersect(Target, Range("A:C,G:G,F:F")) Is Nothing Then Exit Sub
    Select Case Target.Column
        Case Is = 1
            If Target.Row = 1 Then Exit Sub
            If Target.Offset(, 1).Value = "REST" Or Target.Offset(, 1).Value = "" Then Exit Sub
        Case Is = 2
            If Target.Value = "REST" Then
                Target.Font.Italic = True
                Range("E" & Target.Row).ClearContents
                Range("F" & Target.Row).Select
                If Target.Row <= 6210 And Target.Value <> "REST" Then
                    Range("A" & Target.Row).Resize(, 7).Interior.Color = RGB(251, 243, 181)
                End If
            End If
        Case Is = 3
            If Target.Row >= 2 Then
                Cancel = True
                TopCell = Cells(2, 3).Address
                BottomCell = Cells(Target.Row, 3).Address
                TotalCalc = Application.WorksheetFunction.Sum(Range(TopCell, BottomCell))
                MsgBox "Total miles run to date: " & Format((CLng(0 + TotalCalc)), "#,##0") & "   ", vbOKOnly, "Lifetime Mileage"
            End If
            
        Case Is = 6
            If Target.Address = "$F$1" Then Range("B" & Rows.Count).End(xlUp).Select
            Range("B" & ActiveCell.Row).Select
        Case Is = 7
            v = Range("F2:F" & lRow).Value
            For i = LBound(v) To UBound(v)
                If v(i, 1) Like "Day *" And IsNumeric(Mid(v(i, 1), 5)) Then
                    x = x + 1
                End If
            Next i
            MsgBox x
    End Select
    Application.ScreenUpdating = True
End Sub

 

[Ironman]

Many thanks mumps - still getting 9 as a result though. You'll see from the sheet that there are 389 Day numbers.

(this code should also be adapted in your code for Col A btw):

If Target.Column = 1 And Target.Row > 1 Then
If Target.Row = 1 Or Target.Column > 1 Then Exit Sub
    Cancel = True
    MsgBox "Ensure 'Match case' Box Is Checked", vbExclamation, "Find Box"
    Application.Dialogs(xlDialogFormulaFind).Show

 

[My Aswer Is This]

Many thanks mumps - still getting 9 as a result though. You'll see from the sheet that there are 389 Day numbers.

(this code should also be adapted in your code for Col A btw):

If Target.Column = 1 And Target.Row > 1 Then
If Target.Row = 1 Or Target.Column > 1 Then Exit Sub
    Cancel = True
    MsgBox "Ensure 'Match case' Box Is Checked", vbExclamation, "Find Box"
    Application.Dialogs(xlDialogFormulaFind).Show

When I run the script I get the proper results.

 

[Ironman]

When I run the script I get the proper results.

Hmm, this is what I see.

 

[mumps]

Try:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.CountLarge > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Range("F" & Rows.Count).End(xlUp).Row
    If Intersect(Target, Range("A:C,G:G,F:F")) Is Nothing Then Exit Sub
    Select Case Target.Column
        Case Is = 1
            If Target.Row = 1 Then Exit Sub
            If Target.Offset(, 1).Value = "REST" Or Target.Offset(, 1).Value = "" Then Exit Sub
            Cancel = True
            MsgBox "Ensure 'Match case' Box Is Checked", vbExclamation, "Find Box"
            Application.Dialogs(xlDialogFormulaFind).Show
        Case Is = 2
            If Target.Value = "REST" Then
                Target.Font.Italic = True
                Range("E" & Target.Row).ClearContents
                Range("F" & Target.Row).Select
                If Target.Row <= 6210 And Target.Value <> "REST" Then
                    Range("A" & Target.Row).Resize(, 7).Interior.Color = RGB(251, 243, 181)
                End If
            End If
        Case Is = 3
            If Target.Row >= 2 Then
                Cancel = True
                TopCell = Cells(2, 3).Address
                BottomCell = Cells(Target.Row, 3).Address
                TotalCalc = Application.WorksheetFunction.Sum(Range(TopCell, BottomCell))
                MsgBox "Total miles run to date: " & Format((CLng(0 + TotalCalc)), "#,##0") & "   ", vbOKOnly, "Lifetime Mileage"
            End If
            
        Case Is = 6
            If Target.Address = "$F$1" Then Range("B" & Rows.Count).End(xlUp).Select
            Range("B" & ActiveCell.Row).Select
        Case Is = 7
        Range("A1").CurrentRegion.AutoFilter 6, "Day*"
        x = [subtotal(103,A:A)] - 1
        MsgBox x
    End Select
    Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Hmm, this is what I see.

View attachment 57137

So in column F you have something like this:
Day 12
Day 456
Day 45

389 times
Is that correct?

 

[Ironman]

So in column F you have something like this:
Day 12
Day 456
Day 45

389 times
Is that correct?

Yes, that's correct.

 

[mumps]

Try the macro in Post #45.

 

[Ironman]

Try:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.CountLarge > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long
    lRow = Range("F" & Rows.Count).End(xlUp).Row
    If Intersect(Target, Range("A:C,G:G,F:F")) Is Nothing Then Exit Sub
    Select Case Target.Column
        Case Is = 1
            If Target.Row = 1 Then Exit Sub
            If Target.Offset(, 1).Value = "REST" Or Target.Offset(, 1).Value = "" Then Exit Sub
            Cancel = True
            MsgBox "Ensure 'Match case' Box Is Checked", vbExclamation, "Find Box"
            Application.Dialogs(xlDialogFormulaFind).Show
        Case Is = 2
            If Target.Value = "REST" Then
                Target.Font.Italic = True
                Range("E" & Target.Row).ClearContents
                Range("F" & Target.Row).Select
                If Target.Row <= 6210 And Target.Value <> "REST" Then
                    Range("A" & Target.Row).Resize(, 7).Interior.Color = RGB(251, 243, 181)
                End If
            End If
        Case Is = 3
            If Target.Row >= 2 Then
                Cancel = True
                TopCell = Cells(2, 3).Address
                BottomCell = Cells(Target.Row, 3).Address
                TotalCalc = Application.WorksheetFunction.Sum(Range(TopCell, BottomCell))
                MsgBox "Total miles run to date: " & Format((CLng(0 + TotalCalc)), "#,##0") & "   ", vbOKOnly, "Lifetime Mileage"
            End If
        
        Case Is = 6
            If Target.Address = "$F$1" Then Range("B" & Rows.Count).End(xlUp).Select
            Range("B" & ActiveCell.Row).Select
        Case Is = 7
        Range("A1").CurrentRegion.AutoFilter 6, "Day*"
        x = [subtotal(103,A:A)] - 1
        MsgBox x
    End Select
    Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

That works! Thanks ever so much mumps. Can I please just ask you to modify your code slightly for Col F because I'm unable to double click anything in that column without Col B becoming the active column?

Edit: Also, the last line

If Selection.Address = "$F$1" Then Range("B" & Rows.Count).End(xlUp).Select/CODE] needs to be included

Thanks again!

 

[mumps]

Delete this line of code:

Range("B" & ActiveCell.Row).Select