Best way to detect changes in one workbook and make changes in another workbook

[ellak123]

Hi there, I am trying to create a workbook that allows employees to enter working from home hours in one excel workbook - each employee has their own tab and they fill in the days when they were at home. Column D fills colour blue on a day the work from home.

Date	Start Time	Finish Time	WFH
15 Mar 22
16 Mar 22	8:30	17:00	*Blue*
17 Mar 22
18 Mar 22

There is a separate workbook as Holiday Planner(created years ago) which is used to keep track of employees on leave, offsite etc. with different colours. So if John Doe edits his sheet(above) the corresponding date below will change to blue.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    With Sh
        Dim clrCol, cl As Range
        Dim wbk As Workbook
        Dim hws As Worksheet
        Dim ddate, name As String
        Dim dayNum, monthNum As Integer
            
        Set wbk = Workbooks.Open("C:\Users\myName\Desktop\HolidayPlanner.xlsx")
        Set hws = wbk.Worksheets("2022")
        Set clrCol = Range("G" & Target.Row)
        
        'Detects changes made to column E(Finish Time)
        If Not Application.Intersect(Target, Range("E:E")) _
            Is Nothing Then
            If Target.Value = "" Then
                'Revert blue cell to clear
                clrCol.Interior.ColorIndex = 0 'No fill
                'Name to search in col B of holiday planner
                name = ActiveSheet.name
                ddate = Cells(Target.Row, 2).Value
                monthNum = month(ddate)
                dayNum = day(ddate)
                MsgBox name & " " & dayNum & " " & monthNum
            Else
                'Change colour to blue for WFH
                clrCol.Interior.Color = RGB(0, 0, 255) 'blue(wfh)
                'Name to search in col B of holiday planner
                name = ActiveSheet.name
                ddate = Cells(Target.Row, 2).Value
                monthNum = month(ddate)
                dayNum = day(ddate)
                
                With hws
                    'Get the first row of March in Holiday Planner
                    'Then will search that row for the dayNum
                    Set FindRow = .Range("H:H").Find(What:=MonthName(monthNum), LookIn:=xlValues)
                    MsgBox FindRow
                End With
            End If
        End If
        
    End With
bm_Safe_Exit:
    Application.EnableEvents = True
End Sub

I am trying to find the correct cell using the below code but I think I am mixing up the workbooks when I open holidayPlanner before running the code - giving the error "Method 'Intersect' of _Application' failed" . If you have a better/different approach to the code I'd love to see it.
Any help appreciated!

 

[DacEasy]

Hi ellak123,

This looks like a good one to try. If you can copy and paste the calendar like you did the table above it, I will try it.

​

 

[ellak123]

Hi ellak123,

This looks like a good one to try. If you can copy and paste the calendar like you did the table above it, I will try it.

​

HolidayPlanner.xlsx
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK
63		9						10							11							12							13				March
64	EMPLOYEE	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79			1/2
80
81
82
83
84
85
86
87
88
89
2022

Cell Formulas
Range	Formula
D64:AG64	D64	=C64+1

 

[ellak123]

HolidayPlanner.xlsx
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK
63		9						10							11							12							13				March
64	EMPLOYEE	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79			1/2
80
81
82
83
84
85
86
87
88
89
2022

Cell Formulas
Range	Formula
D64:AG64	D64	=C64+1

Sorry for the delay

 

[DacEasy]

Hi ellak123,

Ok, I was able to create what you described, I think. I couldn't test it on a network with multiple people, but Excel will notify you when a file is in use or opened by another.

The code below goes into Employee Sheet.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cellclr 'Interior.ColorIndex = x, more colors at https://docs.microsoft.com/en-us/office/vba/api/excel.colorindex
    Dim rowName As Range, nmatch As Boolean
    Dim dayNum As String, yearNum As String, monthWord As String
    Dim wbk As Workbook, hws As Worksheet, monthNum As Integer
    Dim lastRow As Long, i As Long, monthStart As Long, monthEnd As Long
    Dim halfday As Integer, x As Integer, ddate, hoursworked
    
    halfday = 5
    
    If Target.Column < 5 Or Target.Column > 8 Then
        GoTo exitPlanner
    End If
    
    If Target.Column = 5 Then                   'Column E or 5 = WFH
        cellclr = 33                            'Blue(Work From Home)
        If Cells(Target.Row, 5) > 0 Then
            Cells(Target.Row, 6).Clear: Cells(Target.Row, 7).Clear: Cells(Target.Row, 8).Clear
        End If
        GoTo locateName
    End If
    
    If Target.Column = 6 Then                   'Column F or 6 = WFO
        cellclr = 3                             'Red(Work From Office)
        If Cells(Target.Row, 6) > 0 Then
            Cells(Target.Row, 5).Clear: Cells(Target.Row, 7).Clear: Cells(Target.Row, 8).Clear
        End If
        GoTo locateName
    End If
    
    If Target.Column = 7 Then                   'Column G or 7 = Vacation
        cellclr = 4                             'Green(Vacation)
        If Cells(Target.Row, 7) > 0 Then
            Cells(Target.Row, 5).Clear: Cells(Target.Row, 6).Clear: Cells(Target.Row, 8).Clear
        End If
        GoTo locateName
    End If
    
    If Target.Column = 8 Then                   'Column H or 8 = Sick Day
        cellclr = 15                            'Grey(Sick Day
        If Cells(Target.Row, 8) > 0 Then
            Cells(Target.Row, 5).Clear: Cells(Target.Row, 6).Clear: Cells(Target.Row, 7).Clear
        End If
        GoTo locateName
    End If
    
    
locateName:

        nmatch = False 'Set's everyone Sheet Name to false, later checks to see if the Sheet Name exists
        
        On Error Resume Next
        'Calculate Hours Worked
        Cells(Target.Row, 4) = Format(((Cells(Target.Row, 3).Value) - (Cells(Target.Row, 2).Value)), "hh:mm")
        hoursworked = Cells(Target.Row, 4).Text 'Column D or 4 = Hours Worked
        On Error Resume Next
            
        ddate = Cells(Target.Row, 1).Value      'example: 10-Mar-22
        monthNum = Month(ddate)                 '=3
        monthWord = MonthName(monthNum)         '= March
        dayNum = Day(ddate)                     '= 10
        yearNum = year(ddate)                   '= 2022
        'Call updatePlanner '- This will open the Planner so that
                            'it's undetected. Uncomment when ready to use.
        
        Set wbk = Workbooks("HolidayPlanner.xlsx")

        On Error Resume Next
        Set hws = wbk.Worksheets(yearNum)
        On Error GoTo noSheet                   'if sheet Year doesn't exist, exit with message
        
        lastRow = hws.Range("B" & Rows.Count).End(xlUp).Row
       
        'find the Month in word start and ending row in Column AH
        For i = 1 To lastRow
            If hws.Range("AH" & i).Value = monthWord Then
                monthStart = hws.Range("AH" & i).Row
                monthEnd = monthStart + hws.Range("AH" & i).MergeArea.Rows.Count - 1
            End If
        Next i
        
        'check if employee name(Sheet Name) exist on the planner for that year and month
        For Each rowName In hws.Range("B" & monthStart & ":B" & monthEnd)
            If rowName = ActiveSheet.name Then
                nmatch = True
                GoTo updateRow
            End If
        Next rowName
        GoTo updateRow
    
    
updateRow:
    If nmatch = False Then      'If the Sheet Name is not on Planner, msgbox
        MsgBox ("The name " & ActiveSheet.name & " is not on the Planner for " _
         & monthWord & " " & hws.name & ".")
        GoTo exitPlanner
    End If
    
    Dim dayCol As Long
    dayCol = hws.Cells(monthStart + 1, 1).EntireRow.Find(What:=dayNum, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    hws.Cells(rowName.Row, dayCol).Interior.ColorIndex = cellclr

    x = Split(hoursworked, ":")(0)
    If x < halfday Then
        hws.Cells(rowName.Row, dayCol).Value = "'1/2"
    Else
        hws.Cells(rowName.Row, dayCol).Value = "'"
    End If
    GoTo exitPlanner
        
        
noPlanner:
    MsgBox ("The planner " & wbk & " cannot be found.")
    GoTo exitPlanner


noSheet:
    MsgBox ("The sheet " & yearNum & " has not been created in the Planner or the Date is invalid.")
    GoTo exitPlanner
    
    
exitPlanner:
'wbk.Close True '- This will close the Planner so that
                'it's undetected. Uncomment when ready to use.

End Sub

The code below opens the Holiday Planner undetected for updating:

Option Explicit

Public Sub updatePlanner()
Dim Path
    Path = "C:\sage\HolidayPlanner.xlsx"  'the workbook path you want to refresh

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With

    Workbooks.Open Path
    ActiveWorkbook.UpdateLink name:=ActiveWorkbook.LinkSources
    'ActiveWorkbook.Close True

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub

The picture shows 2 errors you may see if the Year doesn't exist or the Employed Name doesn't exist on the sheet because of spelling, etc.

 

[ellak123]

Hi ellak123,

Ok, I was able to create what you described, I think. I couldn't test it on a network with multiple people, but Excel will notify you when a file is in use or opened by another.

The code below goes into Employee Sheet.

Hi DacEasy,

Thank you so much, I really appreciate your help and the answer is really clear. I will add it to my worksheet today