How do I get this code to run only when certain text is entered in cells?

Ironman

Ironman

Well-known Member
Joined
Jan 31, 2004
Messages
1,069
Office Version
  1. 365
Platform
  1. Windows
Hi

The below code runs in a worksheet_change event but I specifically only want it to run when the word "OTHER" is entered in Column B of the first filled row (same row as the one in the code) AND Column J of the same row begins with the text "Indoor bike session".
VBA Code: 
Dim NextRow As Long
Application.EnableEvents = False
  If ActiveSheet.Name = "Training Log" Then
    NextRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    Range("A" & NextRow).Select
  Else
    MsgBox "Cell fill does not work in this sheet", vbInformation, "Information"
  End If

lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If

Hope you can help?

Many thanks!
 
Last edited:
Sort by date Sort by votes
So if it is a worksheet change event, i'm guessing it will be in the "Training Log" sheet ??
If so, then this line is redundant for starters
VBA Code: 
 If ActiveSheet.Name = "Training Log" Then
AND this wouldn't be required
VBA Code: 
 MsgBox "Cell fill does not work in this sheet", vbInformation, "Information"
 
Upvote 0
Thanks Michael!

Yes, that's correct.

This is what I have now and it runs, but every time data is entered in Col A.
VBA Code: 
Dim NextRow As Long
    NextRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    Range("A" & NextRow).Select

Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If

As I mentioned, I want this to run only when the word "OTHER" is entered in Column B of the first filled row (same row as the one in the code) AND Column J of the same row begins with the text "Indoor bike session".

Thanks again!
 
Upvote 0
Ok..so after the next row line you will need an if statement fsaying if range B & nextrow = OTHER and InStr (range J& nextrow, "Indoor bike session").....you get the idea and i dont have excel atm
 
Upvote 0
No worries Michael, whenever you're ready.

This is what I have, which I've run and it doesn't run as it should
VBA Code: 
Dim NextRow As Long
    NextRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    Range("A" & NextRow).Select

If Range("B" & NextRow) = OTHER And InStr(Range("I" & NextRow), "Indoor bike session") Then
Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
End If

For clarity, the above is my attempt to consolidate the 2 macros below in the order shown into Training Log worksheet_change event, and both of these run perfectly separately:

Macro 1 (workbook module):
VBA Code: 
Sub FillEndRowBlue()
Dim NextRow As Long
  If ActiveSheet.Name = "Training Log" Then
    NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    Range("A" & NextRow).Select
  Else
    MsgBox "Cell fill does not work in this sheet", vbInformation, "Information"
  End If
End Sub
Macro 2 (in Training Log worksheet_change event):
VBA Code: 
Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
 
Upvote 0
When you keep saying the first filled row do you really mean the last row ie: the bottom row of data ?

When you are calculating that row number, the change event being triggered from column B, are you sure that column A isn't blank ?

What is the purpose of, or reason for, calculating the row number and not just using target.row ?
 
Upvote 0
NoSparks said:
When you keep saying the first filled row do you really mean the last row ie: the bottom row of data ?

When you are calculating that row number, the change event being triggered from column B, are you sure that column A isn't blank ?

What is the purpose of, or reason for, calculating the row number and not just using target.row ?
Click to expand...
Hi, thanks for replying

1. Sorry, yes, the bottom row of data

2. Column A is blank until I input a date. I then input text in Col B and ONLY when it's OTHER *AND* Col I begins with the text string then the rest of the code should run.

3. I'm afraid I can't answer that as I was given the code. I can only guess it's to ensure the correct row is filled? Whatever amendments are needed to make the above run correctly are fine by me.
 
Last edited:
Upvote 0
Can you right click on your "Training Log" sheet tab, click view code and when the sheet module comes up
Ctrl+A to select it all, Ctrl+C to copy it all and paste it between code tags in a reply.
Thanks.
 
Upvote 0
Ok, I hope you're ready for this :)...the relevant code is halfway down.

Thanks again!

VBA Code: 
'Private Sub Worksheet_Activate()

'The following line ensures worksheet view is always set to the last entry.
'If you want the active cell to be the first blank cell, uncomment this line and change last part to .Offset(1, 0).Select
'NB - if you do this, you won't be able to make use of the Analysis & Race Log hyperlinks back to Training Log!

'Range("A23358").End(xlUp).Offset(0, 0).Select

'08.09.2021 Paul - this code is probably related to the RouteInfo form but I can't find any reference to it in that code.
Private Function AllFilled(target As Range) As Boolean
AllFilled = False
If Range("A" & target.Row) <> "" And Range("B" & target.Row) <> "" And Range("C" & target.Row) <> "" And _
Range("D" & target.Row) <> "" And Range("E" & target.Row) <> "" Then
    AllFilled = True
End If
End Function

Private Sub Worksheet_SelectionChange(ByVal target As Range)
' When Cell A11 ("A Eleven") is selected, goto bottom of sheet
If target.Address = Range("A11").Address Then
Range("A23358").End(xlUp).Offset(0, 0).Select
End If

' 01.09.2021 Below code courtesy of JohnnyL triggers msgbox when hours exercised this month (J1) exceeds last month (J2)
'https://www.mrexcel.com/board/threads/can-anyone-explain-whats-happening-in-this-fairly-simple-code-please.1180625/page-3#posts

If Not Intersect(target, Range("J1:J2")) Is Nothing Then                                '  <--- Set this to the range you want

        Dim sCurYearMonth As String                                                     '  Establish variable sCurYearMonth as a String

        sCurYearMonth = Format(Now, "YYMM")                                             ' Set the date variable to a yymm format eg 2109
'Application.EnableEvents = False  Paul, this row was removed, don't know why
        If sCurYearMonth > Range("H2").Value Then                                       ' If this is a new month then ...
            Range("H1").Value = 0                                                       '   Set Monthly Msgbox Flag (marker cell) H1 = 0 ie. hasn't displayed yet
            Range("H2").Value = sCurYearMonth                                           '   Save the date variable into H2
        End If

        If (Range("J1").Value > Range("J2").Value) And (Range("H1").Value = 0) Then     ' If J1 is greater than J2 & Monthly MsgBox Flag hasn't been set Then ...
            Range("H1").Value = 1                                                       '   Set Monthly Msgbox Flag H1 = 1

'           Display Message box
            MsgBox "Congratulations!" & vbNewLine & "You've now exercised more than you did last month!   ", vbInformation, "Monthly Exercise"
        End If
    End If
'Application.EnableEvents = True  Paul, this row was removed, don't know why

' 01.09.2021 Below code triggers msgbox when miles run this month (J4) exceeds last month (J5)

If Not Intersect(target, Range("J4:J5")) Is Nothing Then                                ' <--- Set this to the range you want

        sCurYearMonth = Format(Now, "YYMM")                                             ' Set the date variable to a yymm format eg 2109'
       
        If sCurYearMonth > Range("H2").Value Then                                       ' If this is a new month then ...
            Range("H5").Value = 0                                                       '   Set Monthly Msgbox Flag H5 = 0 ie. hasn't displayed yet
            Range("H2").Value = sCurYearMonth                                           '   Save the date variable into H2 (same as used for J1:J2 range)
        End If

        If (Range("J4").Value > Range("J5").Value) And (Range("H5").Value = 0) Then     ' If J4 is greater than J5 & Monthly MsgBox Flag hasn't been set Then ...
            Range("H5").Value = 1                                                       '   Set Monthly Msgbox Flag H5 = 1

'           Display Message box
            MsgBox "Congratulations!" & vbNewLine & "You've run more miles than you did last month!   ", vbInformation, "Monthly Mileage"
        End If
    End If

End Sub


Private Sub Worksheet_Change(ByVal target As Range)

' Courtesy of Peter SS 09.08.2021 - replaces this formula =SWITCH(TODAY()-MAXIFS(A12:A23358,B12:B23358,"<>REST",B12:B23358,"<>"),0,"Exercised Earlier Today",1,"Last Exercise Yesterday","Last Exercise " &TEXT(MAXIFS(A12:A23358,B12:B23358,"<>REST",B12:B23358,"<>"),"d mmm"))
' and shades A8 same as either Running or Other (Row 23358 = 100th birthday :-))
' https://www.mrexcel.com/board/threads/code-needed-instead-of-existing-formula-to-match-fill-colour-of-cell.1178650/

CALC = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

  Dim r As Long, Clr As Long
  Dim Txt As String
 
  If Not Intersect(target, Columns("B")) Is Nothing Then
    With Range("A12", Range("B" & Rows.Count).End(xlUp))
      r = .Rows.Count
      Do Until UCase(.Cells(r, 2).Value) <> "REST" And Not IsEmpty(.Cells(r, 2).Value)
        r = r - 1
      Loop
      Select Case Date - .Cells(r, 1).Value
        Case 0: Txt = "Today"
        Case 1: Txt = "Yesterday"
        Case Else: Txt = Format(.Cells(r, 1).Value, "d mmmm")
      End Select
      Clr = .Cells(r, 1).Interior.Color
    End With
    Application.EnableEvents = False
    With Range("A8")
      .Value = "Last Exercise " & Txt
      .Interior.Color = Clr
    End With
    Application.EnableEvents = True
  End If
 
'15.08.2021 Line below creates CTRL (^) + \ keyboard shortcut to TLPopulateIndoorBikeEntry (FillEndRowBlue) macro in FillButtons module (shading cells for new Indoor Bike session before data input)
 Application.OnKey "^\", "FillEndRowBlue"
 
 
 '03.09.2021 The following creates a msgbox when the max YTD mileage and run duration have been exceeded Courtesy of Eric W https://www.mrexcel.com/board/threads/message-box-when-cell-value-becomes-largest-in-range.1180863/
 'The code was amended to autoupdate every Jan 1 Courtesy of Peter_SSs https://www.mrexcel.com/board/threads/change-range-in-worksheet_change-event-code-every-jan-1.1180867/#post-5747473
 'WARNING FROM PETER S_Ss: If more than one cell is changed at once, the code will error (Code 13 - Type Mismatch)
  'e.g. pasting rest day formatting + if you run the above FillEndRowBlue macro in FillButtons module and then drag the handle up to change the shading back to green.
  'If this happens, just reset the error.
   
    Dim MyData As Variant, OldMax As Double
    Dim ThisYearRow1 As Long, ThisYearDays As Long
    Dim rng As Range
   
    Const BaseRow As Long = 8413 'Row 8413 i.e. 1 Jan 2021
   
    ThisYearRow1 = DateSerial(Year(Date), 1, 1) - DateSerial(2021, 1, 1) + BaseRow
    ThisYearDays = DateSerial(Year(Date) + 1, 1, 1) - DateSerial(Year(Date), 1, 1)
   
    Set rng = Range("C" & ThisYearRow1).Resize(ThisYearDays)
    If Not Intersect(target, rng) Is Nothing Then
        MyData = rng.Value
        MyData(target.Row - ThisYearRow1 + 1, 1) = ""
        OldMax = WorksheetFunction.Max(MyData)
        If target.Value > OldMax Then MsgBox "Congratulations - you've now run the furthest number of miles this year!", vbInformation, "Furthest Run So Far This Year"
    End If
   
    Set rng = rng.Offset(, 1) 'For Column D
    If Not Intersect(target, rng) Is Nothing Then
        MyData = rng.Value
        MyData(target.Row - ThisYearRow1 + 1, 1) = ""
        OldMax = WorksheetFunction.Max(MyData)
        If target.Value > OldMax Then MsgBox "Congratulations - you've now run for the longest time this year!", vbInformation, "Longest Run Duration YTD"
    End If


'20.09.2021 For new indoor bike entry - jumps to Col F after entering data in Cols A & B - works in tandem with TLPopulateIndoorBikeEntry (FillEndRowBlue) module (activated with Control+\)
'           The commented out rows are my attempt to combine the 2 but it's not working as it should.  Pending solution https://www.mrexcel.com/board/threads/how-do-i-get-this-code-to-run-only-when-certain-text-is-entered-in-cells.1182301/
Dim NextRow As Long
    'NextRow = Range("A" & Rows.Count).End(xlUp).Row
    'Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    'Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    'Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    'Range("A" & NextRow).Select
    ''Range("B" & NextRow).Value = "OTHER" line commented out as won't update unless this value is manually input
    'If Range("B" & NextRow) = OTHER And InStr(Range("I" & NextRow), "Indoor bike session") Then

Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
'End If

                                         'Florante Kho
                                        
                                '******************************
                                '********Modularisation********
                                '******************************

'This separates different tasks in order to isolate sections that are not working properly.

 'Messages are contained here:
    Call ImportantMessages

Application.Calculation = CALC
Application.Calculate
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub


Sub ImportantMessages()

'**************************************************************
'*******This procedure is called in Sub WorksheetChange********
'**************************************************************
'This procedure contains all your important messages:

'NEED TO RE-ENABLE THIS 01.01.2022 (2021 commented out 09.08.2021 when 2020 total exceeded)
'If Range("IRONMAN_YTD") > Worksheets("Iron Man Log").[A201] Then 'update cell reference when location amended for new year
'If [H9] = "" Then
'MsgBox "Congratulations! You've now completed more Iron Man runs this year than the whole of last year!", vbInformation, "Iron Man Runs"
'[H9] = "1"
'End If
'End If

If Range("VBA_YTD_DAYS") = 183 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the bronze standard   " & vbNewLine _
& "you've exercised three times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If

If Range("VBA_YTD_DAYS") = 256 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the silver standard   " & vbNewLine _
& "you've exercised five times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If

If Range("VBA_YTD_DAYS") = 329 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the gold standard   " & vbNewLine _
& "you've exercised at least six times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If

If Range("VBA_YTD_MILES") > 499 And Range("VBA_YTD_MILES") < 504 Then
If [H5] = "" Then
MsgBox "Congratulations! You've now run your 500th mile this year", vbInformation, "Year to Date Mileage"
[H5] = "1"
End If
End If

If Range("VBA_YTD_MILES") > 999 And Range("VBA_YTD_MILES") < 1010 Then
If [H5] = "" Then
MsgBox "Congratulations! You've now run your 1,000th mile this year", vbInformation, "Year to Date Mileage"
[H5] = "1"
End If
End If

If Range("No_MILES_RUN_SINCE_1981") > 27990 And Range("No_MILES_RUN_SINCE_1981") < 28000 Then
If [H6] = "" Then
MsgBox "You're now approaching 28,000 miles!", vbInformation, "Miles Run Since 16.04.1981"
[H6] = "1"
End If
End If

If Range("No_MILES_RUN_SINCE_1981") > 28000 And Range("No_MILES_RUN_SINCE_1981") < 28010 Then
If [H6] = "" Then
MsgBox "Congratulations! You've now run over 28,000 miles!", vbInformation, "Miles Run Since 16.04.1981"
[H6] = "1"
End If
End If

If Range("No_MILES_RUN_SINCE_1981") > 28505 And Range("No_MILES_RUN_SINCE_1981") < 28515 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just run your 10,000th mile from here!", vbInformation, "Miles Run from Hallas Hall Farm"
[H6] = "1"
End If
End If

If Range("No_DAYS_SINCE_1981") = 6000 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just come back from your 6,000th run!", vbInformation, "Days Run Since 16.04.1981"
[H6] = "1"
End If
End If

If Range("No_DAYS_SINCE_1981") = 7000 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just come back from your 7,000th run!", vbInformation, "Days Run Since 16.04.1981"
[H6] = "1"
End If
End If

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)

'22.08.2021 The following code (courtesy of Crystalyzer www.mrexcel.com/board/threads/search-2-sheets-for-a-date.1179788/)
'Opens find date box when double clicking Cell A12>

    If target.Column = 1 And target.Row > 11 Then
        Call FindDate
    End If

    ' check Target is in column H
    If Cells(target.Row, "B").Value = "OTHER" Or Cells(target.Row, "B").Value = "REST" Or Cells(target.Row, "B").Value = "" Then Exit Sub ' when any cell in column H row 12 downwards is double-clicked, except OTHER, REST entries or empty cells
                                                                                                     ' Courtesy of Michael M 06.08.2021 www.mrexcel.com/board/threads/add-simple-condition-to-code-that-prevents-code-running.1178458/
    If target.Column = 8 And target.Row >= 12 Then
        Cancel = True
        TopCell = Cells(12, 3).Address 'Row 12, Column 3 i.e. mileage
        BottomCell = Cells(target.Row, 3).Address

        TotalCalc = Application.WorksheetFunction.Sum(Range(TopCell, BottomCell))

        MsgBox "Total miles run to " & Format(Cells(ActiveCell.Row, 1), "dd mmmm yyyy: ") & _
                     Format((CLng(10724.97 + TotalCalc)), "#,##0") & "   ", vbOKOnly, "Lifetime Mileage"
   
    End If
   
End Sub

Sub xx()
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
Upvote 0
try replacing this part
VBA Code: 
Dim NextRow As Long
    'NextRow = Range("A" & Rows.Count).End(xlUp).Row
    'Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    'Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    'Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
    'Range("A" & NextRow).Select
    ''Range("B" & NextRow).Value = "OTHER" line commented out as won't update unless this value is manually input
    'If Range("B" & NextRow) = OTHER And InStr(Range("I" & NextRow), "Indoor bike session") Then

Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
    Range("F" & lr).Select
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
'End If

with this
VBA Code: 
'monitor column B for OTHER and what's in column I
If target.Column = 2 And target.Value = "OTHER" And Range("I" & target.Row).Value = "Indoor bike session, 60 mins." Then
    Range("A" & target.Row).Resize(, 6).Interior.Color = RGB(197, 217, 241)
    Range("I" & target.Row).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    'select cell col F
    Application.EnableEvents = False
    Range("F" & target.Row).Select
    Application.EnableEvents = True
    'display message
    MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
End If
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

E
  • Solved
How to specify multiple separate cells for copy in VBA
Replies
4
Views
372
Ed Harris
E
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
448
tixarah
T
M
  • Question Question
What am I doing Wrong?
Replies
6
Views
315
MBarrett
M
R
  • Question Question
"Out of Memory" Error when trying to pivot
Replies
2
Views
62
rachel06
R
A
  • Solved
Could not set the RowSource property. Invalid property value. Error 380
2
Replies
16
Views
414
RoryA
RoryA

Share this page

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
Back
Top