Code shuts down excel

[LindaLinda]

Hello,
I'm a novice at VBA code. This code was originally from one of the YouTube videos for a dynamic yearly event calendar that I wanted to adopt for my specific needs. The problem is that I want events stored and retrieved on a separate worksheet in very specific rows because other calendars will also populate stored/retrievable data on the worksheet (Datasheet). When I run this code and start clicking on the calendar, it shuts down excel. What am I doing wrong?

Option Explicit
Dim YearNm As Long, DayCol As Long, DayRow As Long
Dim DataSheet As Worksheet
Dim SelDate As Date

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("AH8:AH12")) Is Nothing Then
'If the user selects a date within the Target
SelDate = Range("AH6")
'The Dim YearNm equals whatever value is in cell D2
YearNm = Range("D2").Value

'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error GoTo 0
If DataSheet Is Nothing Then
ThisWorkbook.Sheets.Add(After:=Sheets("AHE Yearly")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
Activate 'This activates the current sheet. In this case AHE Yearly
End If

DayRow = Target.Row 'Determine Row for DataSheet
DayCol = SelDate - DateSerial(YearNm, 1, 1) + 2 'Determine Column for DataSheet
Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value

End If
End Sub

'Creates new Worksheet when the user adds information to daily activities.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'If user selects what is not desired (alternatively saying that the Target must be a date within a range in a single cell)
'Specifically if more than one cell or an empty cell within a range or it isn't a date then exit sub
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("B7:AF30")) Is Nothing Then
If IsDate(Target.Value) = False Then Exit Sub
'If the user selects a date within the Target
SelDate = Target.Value
'The Dim YearNm equals whatever value is in cell D2
YearNm = Range("D2").Value
'The cell AH6 will display the value of the Dim for SelDate
Range("AH6").Value = SelDate

'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error GoTo 0
If DataSheet Is Nothing Then
ThisWorkbook.Sheets.Add(After:=Sheets("AHE Yearly")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
Activate 'This activates the current sheet. In this case AHE Yearly
End If

DayRow = Target.Row 'Determine Row for DataSheet
DayCol = SelDate - DateSerial(YearNm, 1, 1) + 2 'Determine Column for DataSheet
Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value

End If
End Sub

 

[StephenCrump]

Welcome to the Forum!

Just a very quick observation (I haven't tried to understand what your code is doing) ...

You have this line in both Subs:

Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value

This will trigger a call to Sub Worksheet_Change, which will trigger a call to Sub Worksheet_Change etc etc in an infinite loop.

To avoid this happening:

Application.EnableEvents = False
Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value
Application.EnableEvents = True

 

[LindaLinda]

Welcome to the Forum!

Just a very quick observation (I haven't tried to understand what your code is doing) ...

You have this line in both Subs:

Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value

This will trigger a call to Sub Worksheet_Change, which will trigger a call to Sub Worksheet_Change etc etc in an infinite loop.

To avoid this happening:

Application.EnableEvents = False
Range("AH8:AH12").Value = DataSheet.Range(DataSheet.Cells(20, DayCol), DataSheet.Cells(25, DayCol)).Value
Application.EnableEvents = True

Thank you! I'll give it a shot!

 

[Peter_SSs]

@LindaLinda
I have removed the solution tick from post #3 since it does not contain a solution. If post #2 provided the solution then please mark that otherwise please don't mark anything as the solution.