VBA to run routine based on month in corresponding cell

[EssKayKay]

Hello,

I’m looking for a VBA routine that checks if the month of a date in the corresponding row is December; if so, run another routine. Column “C” contain dates; Column “M” is where the entry to be checked will be entered. I assume I want to place the code in the Worksheet_SelectionChange sub.

As example – if an entry is made in cell M44, then check if the month of the date in C44 is 12 (i.e., December). If it is, then run a subroutine called DistributePITI().

Thanks for viewing,
Steve K.

 

[Joe4]

If you are making manual updates to column M, you want to use "Worksheet_Change", not "Worksheet_SelectionChange" (which runs simply on the selection of cells).

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range
    Dim rng As Range
   
'   Check for entry made to column M
    Set rng = Intersect(Target, Columns("M:M"))
   
'   If not entry made in column M, exit
    If rng Is Nothing Then Exit Sub
   
'   Loop through new entries made in column M
    For Each cell In rng
'       Check month of date in column C
        If (cell.Offset(0, -10) <> "") And (Month(cell.Offset(0, -10)) = 12) Then
'           Call procedure
            Call DistributePITI
        End If
    Next cell

End Sub

 

[EssKayKay]

If you are making manual updates to column M, you want to use "Worksheet_Change", not "Worksheet_SelectionChange" (which runs simply on the selection of cells).

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range
    Dim rng As Range
 
'   Check for entry made to column M
    Set rng = Intersect(Target, Columns("M:M"))
 
'   If not entry made in column M, exit
    If rng Is Nothing Then Exit Sub
 
'   Loop through new entries made in column M
    For Each cell In rng
'       Check month of date in column C
        If (cell.Offset(0, -10) <> "") And (Month(cell.Offset(0, -10)) = 12) Then
'           Call procedure
            Call DistributePITI
        End If
    Next cell

End Sub

Hello Joe,

Thank you for getting back to me so quickly. This is working almost perfectly. However, there is another sub I run that triggers a Run-time error 13 Type Mismatch. Here’s where it hangs:

As a test, I added On error resume next at the beginning of your code and it worked better. However, there were some other portions of the Worksheet_Change sub that were not being processed. So I placed your code as the last part of Worksheet_Change and it appears to be working fine. I still have quite a bit of testing to do but this looks very promising

Any suggestions on the error?

Thanks again,
Steve K.

 

[Joe4]

Do you have any non-date entries in column C, i.e. text or errors possibly?
If you could provide the details of a record that errors (what are you entering in column M, what is in column C for that row), that might be helpful!

 

[EssKayKay]

I don't think I can shed too much light on this Joe but I will try. If you want to pass on this I totally understand. Right now the On Errror Resume Next appears to be doing what I want so that may be OK with me.

There are only dates in column C. There error occurs when I try to run another routine That I assume is accesses some cell(s) that are affected by the Worksheet_Change. I have posted the routine that I believe is triggering the error and my Worksheet_Change routines. However, I must note my code for both will most likely be hard to follow as it will be unbelievably sloppy as I am not a programmer. I don't expect you to review all the code - just too much.\\

Public Sub ClearALL()
Dim DoIt1 As Integer
Dim DoIt2 As Integer
Dim OrgCell As Range
Set OrgCell = ActiveCell

Application.EnableEvents = False
Application.ScreenUpdating = False

If Range("TempCell") = "Repair" Then
DoIt1 = vbYes
DoIt2 = MsgBox(" --- REPAIR ---" & vbNewLine & vbNewLine & _
" This procedure should speed up the program." & vbNewLine & _
" However, it may take a few minutes to process." _
& vbNewLine & vbNewLine & " Do you wish to continue?", vbYesNo, " Synchcronize Data")


If DoIt2 = vbYes Then
GoTo RepairIT
Else
Range("TempCell") = "---"
Repair_NO
End
End If
End If

UnProtect_It
Range("OneTime") = "---"
Range("TempCell") = "---"

LoanInfoEntered_NO

DoIt1 = MsgBox(" --- CAUTION ---" & vbNewLine & vbNewLine & _
" All entries will be Deleted & Reset!" & vbNewLine & " ~~~~~~~~~~~~~~~~~~~~~~~" _
& vbNewLine & vbNewLine & " Do you wish to continue?", vbYesNo, " Clear All")

RepairIT:
If DoIt1 = vbYes Then
Range("I33").Select
UnProtect_It
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("M33:M" & Range("LastDataRow").Value).Select
UnProtect_It
Selection.ClearContents

UnProtect_It
Range("F6:F8,F10,K6:K13,F15:F17,F22").Select
Selection.ClearContents
UnProtect_It
Range("F11").Select
ActiveCell.FormulaR1C1 = "Monthly"
UnProtect_It
Range("F12").Select
ActiveCell.FormulaR1C1 = "Monthly"

'-----------------------------------------------
UnProtect_It
Range("B" & Range("FormulasRow").Value & ":" & "K" & Range("FormulasRow").Value).Select
Selection.Copy
Range("B33:B" & Range("LastDataRow").Value).Select
Range("B" & Range("LastDataRow").Value).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B33").Select
'-----------------------------------------------

Range("O33:O" & Range("LastDataRow").Value).Select
Selection.ClearContents


UnProtect_It
Range("F6:F8,F10:F12").Select
Selection.Locked = False
Selection.FormulaHidden = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
End With

'---- Freeze One-Time until all Info is added ----
Range("F15:F17,F22,K6:K13").Select
Selection.Locked = True
Selection.FormulaHidden = False
With Selection.Interior
.Color = 15984868
.TintAndShade = 0
End With


UnProtect_It
Range("K32").Select
ActiveCell.FormulaR1C1 = "=loan_amount"
Else

GoTo GoodBye
End If


'xxxxx Added 2/14/24, defaults to 1st Pmt Date (had to run this a 2nd time??? xxxxxx
UnProtect_It
Range("B" & Range("FormulasRow").Value & ":" & "K" & Range("FormulasRow").Value).Select
Selection.Copy
Range("B33:K33").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx


UnProtect_It
Range("P32,K6:K13").Select '--- Added P32 to temporarily not display K6 as active ---
Selection.Locked = True
Selection.FormulaHidden = False
With Selection.Interior
.Color = 15984868
.TintAndShade = 0
End With

SetupData
Range("P33:U33").ClearContents

GoodBye:
Application.ScreenUpdating = True
LoanInfoEntered_YES

If DoIt1 = vbYes Then
Range("F6").Select
Else
OrgCell.Select
End If


Application.ScreenUpdating = True
Application.EnableEvents = True
Range("A4,H5").Select
Range("H5").Activate
Range("F6").Select


Protect_It
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("LoanInfoEntered") = "Y" Then LoanInfo

If Target.Cells.CountLarge = 1 And Not Intersect(Range("M33:M2032"), Target) Is Nothing Then
Application.EnableEvents = False
Dim NewVal As String, OldVal As String
NewVal = Target.Value

OldVal = Target.Value

If Len(OldVal) > 0 And OldVal <> NewVal Then
Target = NewVal
Target.Offset(1).Select
cmdPmtMade_Click
Else
Range("M31").End(xlDown).Offset(1, 0).Select
End If

Application.EnableEvents = True
End If

'=========================
Dim F11_Blank As String, F12_Blank As String
F11_Blank = Range("F11").Text
F12_Blank = Range("F12").Text


If Target.Address = "$F$11" Or Target.Address = "$F$12" Then
If F11_Blank = "" Or F12_Blank = "" Then
MsgBox " OOPS - Blank Field" & vbNewLine & vbNewLine & _
" COMPOUND PERIOD or" & vbNewLine & " PAYMENT FREQUENCY" & vbNewLine & " cannot be blank.", , " Loan Info. . ."
If Range("F11") = "" Then Range("F11") = "Monthly"
If Range("F12") = "" Then Range("F12") = "Monthly"
End If
End If
'=========================

VerifyOneTimePmt '*** Must be run just prior to editing PmtMade ***


'*********** Routines to address editing PmtMade ************
'--------- Restore blank Paym't. Date ---------
If Range("F6").Locked = True Then
Dim d As Range
Set d = Intersect(Target, Range("M33:M2033"))
If d Is Nothing Then Exit Sub
If d.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
If d = "" Then Application.Undo
Application.EnableEvents = True
End If

'----- Highlights DueDate for last PmtMade -----
If Not Intersect(Target, Range("M33:M2032")) Is Nothing And Range("F6").Locked = True Then

If Range("TempCell") = "Editing" Then
sendkeys "{right}{left}"
Range("TempCell") = "Pmt_Made"
Else

'----- To Higlight DueDate -----

On Error Resume Next
Application.EnableEvents = False
Selection.Offset(0, 1).Select
Selection.Offset(0, -1).Select
Application.EnableEvents = True
'-------------------------------

End If
End If

'*****************************************************************



'========= update Distribution Date for nonPITI posts ==============
On Error Resume Next
Dim cell As Range
Dim rng As Range

' Check for entry made to column M
Set rng = Intersect(Target, Columns("M:M"))

' If not entry made in column M, exit
If rng Is Nothing Then Exit Sub

' Loop through new entries made in column M
For Each cell In rng
' Check month of date in column C
If (cell.Offset(0, -10) <> "") And (Month(cell.Offset(0, -10)) = 12) Then
' Call procedure
Call DistributePITI
End If
Next cell
'======================================================================


If Not Intersect(Target, Range("M:M")) Is Nothing And Target.CountLarge = 1 Then
Range("M31").End(xlDown).Offset(1, 0).Select
End If

If Not Intersect(Target, Range("K6:K7")) Is Nothing And Target.CountLarge = 1 Then
Application.ScreenUpdating = False

SetLookupDate
Range("F6").Select
Range("C2").Select
Application.ScreenUpdating = True
End If

GoodBye:
End Sub

 

[EssKayKay]

Let's put this on hold for now. I ran into a bigger issue I'll have to resolve before addressing this.
Thanks for your time and consideration.

 

[Joe4]

I think I see the issue, and it is this part here, I believe:

Range("M33:M" & Range("LastDataRow").Value).Select
UnProtect_It
Selection.ClearContents

The issue is, the Worksheet_Change event is called whenever a cell and your sheet is updated, and we are specifically looking at cells in column M.
Well, that code above is making updates to column M, which causes your Worksheet_Change code to fire again!

Just like you did in other parts of your code, you will want to temporarily disable events from firing due to the code changes by putting this line of code before those changes:

Application.EnableEvents = False

and then adding this line after the changes to turn the events back on:

Application.EnableEvents = True