Copied sheet code to new file and lost some functionality....not sure how/why

MeaclH · Nov 5, 2024

Hi all,

I had a wonderful bunch of code working perfectly on a project, but I have been asked to change the formatting and layout of the sheet and thought it would be easiest to create a new file and transfer sheet code across.
In doing so, some of the functionality is not working and I can't for the life of me figure it out.
Not sure the best way to get you up to speed but attached is a mini sheet, and below is the sheet code. I have highlighted in red the sections that are not triggering when the change is made on the sheet.
It should be known, I didn't write this code, it was made up from contributions from some very handy people on here as my skills are lacking somewhat.

Thanks in advance for your help.
Hayden

Rich (BB code):

Dim pVal
Dim swapval As Boolean

Public Sub Worksheet_SelectionChange(ByVal Target As Range)
pVal = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Resp As String
Dim prevValue
prevValue = pVal

On Error GoTo ExitNow
Application.EnableEvents = False
If Target.CountLarge = 1 And Not Intersect(Target, Range("G10:T153")) Is Nothing Then '<--- Change Target Range Here
    If swapval = False Then
'---EDO/EDO-U
        If prevValue = "EDO" Or prevValue = "EDO-U" Then
            If InStr(Target.Value, "0") Then
                With Target
                    ActiveSheet.Unprotect
                    .Interior.Color = RGB(0, 176, 240)
                    .Font.Color = RGB(255, 0, 0)
                    'Input Box below. change text and title as needed:
                    Resp = Application.InputBox("You are allocating an open shift to a DAO on an EDO.         Please include details of when this shift was added and notify the DAO at the earliest opportunity.", _
                    Title:="Open shift added on an EDO")
                    ActiveSheet.Protect DrawingObjects:=False
                End With
            End If
        Else
'-------OFF/OFF-U
            If prevValue = "OFF" Or prevValue = "OFF-U" Then
                If InStr(Target.Value, "0") Then
                    With Target
                        ActiveSheet.Unprotect
                        .Interior.Color = RGB(255, 255, 0)
                        .Font.Color = RGB(255, 0, 0)
                        'Input Box below. change text and title as needed:
                    Resp = Application.InputBox("You are allocating an open shift to a DAO on a day OFF.         Please include details of when this shift was added and notify the DAO at the earliest opportunity.", _
                    Title:="Open shift added on a day OFF")
                        ActiveSheet.Protect DrawingObjects:=False
                    End With
                End If
            End If
        End If
    Else
        swapval = False
    End If
'---Absenteeism Details
    With Target
        Select Case .Value
            Case "SDO", "STFN", "CDO", "CTFN" '<- Add more trigger values here if required
                Resp = Application.InputBox("Please insert details of absenteeism", _
                Title:="Absenteeism Details")
            Case "OFF-U", "EDO-U" '<- Add more trigger values here if required
                Resp = Application.InputBox("Please insert details of DAO request to be marked unavailable on OFF/EDO.", _
                Title:="OFF/EDO Unavailability Details")
        End Select
    End With
'---DAO Shift Extension Confirmation/Decline
    With Target
        If InStr(1, .Value, "OK") > 0 Then
            Resp = Application.InputBox("Please enter details of when this shift extension was confirmed by the DAO. " & _
            "Including time and date and how it was confirmed", "DAO Shift Extension Confirmation", , , , , , 2)
        Else
            If InStr(1, .Value, "DEC") > 0 Then
                Resp = Application.InputBox("Please enter details of when this shift extension was declined by the DAO. " & _
                "Including time and date when it was declined", "DAO Shift Extension Declined", , , , , , 2)
        Else
            If InStr(1, .Value, "?") > 0 Then
                Resp = Application.InputBox("Please enter details of when this shift extension was added to the DAOs roster. " & _
                "Including time and date when it was added", "DAO Shift Extension added", , , , , , 2)
                End If
            End If
        End If
    End With
    Call AddComment(Target, Resp)
End If

ExitNow:
Application.EnableEvents = True
End Sub

Sub AddComment(rng As Range, cTxt As String)
With rng
    If Len(cTxt) > 0 And cTxt <> "False" Then
        If .Comment Is Nothing Then
            ActiveSheet.Unprotect
            .AddComment Text:=cTxt
            ActiveSheet.Protect DrawingObjects:=False
        Else
            ActiveSheet.Unprotect
            .Comment.Text .Comment.Text & vbLf & cTxt
            ActiveSheet.Protect DrawingObjects:=False
        End If
    End If
End With
End Sub
Sub ActionSwap()
Dim sCmt As String
Dim i As Long
Dim rCell As Range
Dim area1 As Variant, area2 As Variant, swapval As Variant
   
sCmt = InputBox( _
  Prompt:="Enter details of the swap. Including when it was actioned and by who." & vbCrLf & _
  "Comment will be added to all cells in Selection", _
  Title:="DAO Swap Details")
If sCmt = "" Then
    MsgBox "No comment added"
Else
    For Each rCell In Selection
    With rCell
        If .Comment Is Nothing Then
        .AddComment.Text sCmt
    Else
        .Comment.Text sCmt & vbLf & .Comment.Text
    End If
End With
Next
End If
Set rCell = Nothing
If Selection.Areas.Count <> 2 Then Exit Sub
If Selection.Areas(1).Columns.Count <> Selection.Areas(2).Columns.Count Then
    MsgBox ("Selection areas must have the same number of columns")
    Exit Sub
End If
area1 = Selection.Areas(1)
area2 = Selection.Areas(2)
If Selection.Areas(1).Columns.Count = 1 Then
    swapval = area1
    area1 = area2
    area2 = swapval
Else
    For i = LBound(area1, 2) To UBound(area1, 2)
        swapval = area1(1, i)
        area1(1, i) = area2(1, i)
        area2(1, i) = swapval
    Next
End If
Selection.Areas(1) = area1
Selection.Areas(2) = area2
swapval = True
End Sub

DIGITAL ROSTER MACH2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

1

2

FORTNIGHT COMMENCING

SUNDAY

MONDAY

TUESDAY

WEDNESDAY

THURSDAY

FRIDAY

SATURDAY

SUNDAY

MONDAY

TUESDAY

WEDNESDAY

THURSDAY

FRIDAY

SATURDAY

3

4

Employee Name

Open Shifts

5

#CALC!

6

7

8

9

10

DAO Team Leaders

11

Line 1

Rostered T/L

Shift

0530TL

OFF

0530TL

12

13

Original T/L

14

Remarks

9

15

Line 2

Rostered T/L

Shift

1330TL

OFF

1330TL

OFF

16

17

Original T/L

18

Remarks

9

19

Line 3

Rostered T/L

Shift

OFF

1330TL

2130TL

OFF

1330TL

20

21

Original T/L

22

Remarks

9

23

Line 4

Rostered T/L

Shift

2130TL

OFF

2130TL

24

25

Original T/L

26

Remarks

9

27

Line 5

Rostered T/L

Shift

OFF

0700AD

0530TL

OFF

1330TL

1200AD

OFF

28

29

Original T/L

30

Remarks

9

MASTER

Cell Formulas
Range	Formula
G3	G3	=IF(A4="","",A4)
H3:T3	H3	=IF(G3="","",G3+1)
G5,M5:N5,T5	G5	=FILTER('https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - TRIAL (LIVE).xlsm]DATA'!$AL$3:$AL$17,NOT(COUNTIF(G11:G136,'https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - TRIAL (LIVE).xlsm]DATA'!$AL$3:$AL$17)))
H5:L5,O5:S5	H5	=FILTER('https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - TRIAL (LIVE).xlsm]DATA'!$AM$3:$AM$19,NOT(COUNTIF(H11:H136,'https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - TRIAL (LIVE).xlsm]DATA'!$AM$3:$AM$19)))
C11,C27,C23,C19,C15	C11	=IF($A$4="","",VLOOKUP(CONCATENATE(VALUE($A$4),$A11),'https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - trial version backup.xlsm]DATA'!$U$3:$V$1568,2,0))
C13,C29,C25,C21,C17	C13	=IF($A$4="","",VLOOKUP(CONCATENATE(VALUE($A$4),$A11),'https://metrotrains-my.sharepoint.com/personal/hayden_meaclem_metrotrains_com_au/Documents/[DAO DIGITAL ROSTER - trial version backup.xlsm]DATA'!$U$3:$V$1568,2,0))
E14,E30,E26,E22,E18	E14	=SUM(AK11:AX11)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
G5:T5	Cell	contains an error	text	NO
E14,E18,E22,E26,E30	Cell Value	>=12	text	NO
E14,E18,E22,E26,E30	Cell Value	=11	text	NO
E14,E18,E22,E26,E30	Cell Value	=10	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "GAZETTE"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "AV"	text	NO
E14,E18,E22,E26,E30	Cell Value	=9	text	NO
E14,E18,E22,E26,E30	Cell	contains an error	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "EDO-U"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "OFF-U"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "BLV"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "CTFN"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "CDO"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "STFN"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "SDO"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "LSL"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "A/L"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "PHC"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "OFF"	text	NO
G11:T11,G30:T30,G14:T15,G22:T23,G26:T27,G18:T19	Cell Value	contains "EDO"	text	NO
C13,C17,C21,C25,C29	Expression	=IF(C13=C11,TRUE)	text	NO
C2	Cell Value	contains "UNPUBLISHED"	text	NO
C2	Cell Value	contains "PUBLISHED"	text	NO
G6:T9	Cell	contains an error	text	NO
G14:T14,G18:T18,G22:T22,G26:T26,G30:T30	Expression	=NOT(ISERROR(FIND("OK",#REF!)))	text	NO

Cells with Data Validation
Cell	Allow	Criteria
G11:T13	List	=DATA!$AF$4:$AF$47
G15:T17	List	=DATA!$AF$4:$AF$47
G19:T21	List	=DATA!$AF$4:$AF$47
G23:T25	List	=DATA!$AF$4:$AF$47
G27:T29	List	=DATA!$AF$4:$AF$47

MeaclH · Nov 6, 2024

G'day all,
I have this code which works perfectly, however I have needed to change the formatting of the sheet and merge the cells that would be targetted. I believe this is stopping the code from being executed.
Is there something I can change in the code to have it action on merged cells?
Should be mentioned not all the target cells are merged, some are made up of 1 single cell or up to a total of 3 cells merged.

VBA Code:

Dim pVal
Dim swapval As Boolean

Public Sub Worksheet_SelectionChange(ByVal Target As Range)
pVal = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Resp As String
Dim prevValue
prevValue = pVal

On Error GoTo ExitNow
Application.EnableEvents = False
If Target.CountLarge = 1 And Not Intersect(Target, Range("G11:T178")) Is Nothing Then '<--- Change Target Range Here
    If swapval = False Then
'---EDO/EDO-U
        If prevValue = "EDO" Or prevValue = "EDO-U" Then
            If InStr(Target.Value, "0") Then
                With Target
                    ActiveSheet.Unprotect
                    .Interior.Color = RGB(0, 176, 240)
                    .Font.Color = RGB(255, 0, 0)
                    'Input Box below. change text and title as needed:
                    Resp = Application.InputBox("You are allocating an open shift to a DAO on an EDO.         Please include details of when this shift was added and notify the DAO at the earliest opportunity.", _
                    Title:="Open shift added on an EDO")
                    ActiveSheet.Protect DrawingObjects:=False
                End With
            End If
        Else
'-------OFF/OFF-U
            If prevValue = "OFF" Or prevValue = "OFF-U" Then
                If InStr(Target.Value, "0") Then
                    With Target
                        ActiveSheet.Unprotect
                        .Interior.Color = RGB(255, 255, 0)
                        .Font.Color = RGB(255, 0, 0)
                        'Input Box below. change text and title as needed:
                    Resp = Application.InputBox("You are allocating an open shift to a DAO on a day OFF.         Please include details of when this shift was added and notify the DAO at the earliest opportunity.", _
                    Title:="Open shift added on a day OFF")
                        ActiveSheet.Protect DrawingObjects:=False
                    End With
                End If
            End If
        End If
    Else
        swapval = False
    End If
'---Absenteeism Details
    With Target
        Select Case .Value
            Case "SDO", "STFN", "CDO", "CTFN" '<- Add more trigger values here if required
                Resp = Application.InputBox("Please insert details of absenteeism", _
                Title:="Absenteeism Details")
            Case "OFF-U", "EDO-U" '<- Add more trigger values here if required
                Resp = Application.InputBox("Please insert details of DAO request to be marked unavailable on OFF/EDO.", _
                Title:="OFF/EDO Unavailability Details")
        End Select
    End With
'---DAO Shift Extension Confirmation/Decline
    With Target
        If InStr(1, .Value, "OK") > 0 Then
            Resp = Application.InputBox("Please enter details of when this shift extension was confirmed by the DAO. " & _
            "Including time and date and how it was confirmed", "DAO Shift Extension Confirmation", , , , , , 2)
        Else
            If InStr(1, .Value, "DEC") > 0 Then
                Resp = Application.InputBox("Please enter details of when this shift extension was declined by the DAO. " & _
                "Including time and date when it was declined", "DAO Shift Extension Declined", , , , , , 2)
        Else
            If InStr(1, .Value, "?") > 0 Then
                Resp = Application.InputBox("Please enter details of when this shift extension was added to the DAOs roster. " & _
                "Including time and date when it was added", "DAO Shift Extension added", , , , , , 2)
                End If
            End If
        End If
    End With
    Call AddComment(Target, Resp)
End If

ExitNow:
Application.EnableEvents = True
End Sub

Sub AddComment(rng As Range, cTxt As String)
With rng
    If Len(cTxt) > 0 And cTxt <> "False" Then
        If .Comment Is Nothing Then
            ActiveSheet.Unprotect
            .AddComment Text:=cTxt
            ActiveSheet.Protect DrawingObjects:=False
        Else
            ActiveSheet.Unprotect
            .Comment.Text .Comment.Text & vbLf & cTxt
            ActiveSheet.Protect DrawingObjects:=False
        End If
    End If
End With
End Sub
Sub ActionSwap()
Dim sCmt As String
Dim i As Long
Dim rCell As Range
Dim area1 As Variant, area2 As Variant, swapval As Variant
    
sCmt = InputBox( _
  Prompt:="Enter details of the swap. Including when it was actioned and by who." & vbCrLf & _
  "Comment will be added to all cells in Selection", _
  Title:="DAO Swap Details")
If sCmt = "" Then
    MsgBox "No comment added"
Else
    For Each rCell In Selection
    With rCell
        If .Comment Is Nothing Then
        .AddComment.Text sCmt
    Else
        .Comment.Text sCmt & vbLf & .Comment.Text
    End If
End With
Next
End If
Set rCell = Nothing
If Selection.Areas.Count <> 2 Then Exit Sub
If Selection.Areas(1).Columns.Count <> Selection.Areas(2).Columns.Count Then
    MsgBox ("Selection areas must have the same number of columns")
    Exit Sub
End If
area1 = Selection.Areas(1)
area2 = Selection.Areas(2)
If Selection.Areas(1).Columns.Count = 1 Then
    swapval = area1
    area1 = area2
    area2 = swapval
Else
    For i = LBound(area1, 2) To UBound(area1, 2)
        swapval = area1(1, i)
        area1(1, i) = area2(1, i)
        area2(1, i) = swapval
    Next
End If
Selection.Areas(1) = area1
Selection.Areas(2) = area2
swapval = True
End Sub

Cheers
Hayden

Joe4 · Nov 6, 2024

Is this really the same question as your post from yesterday here?

Copied sheet code to new file and lost some functionality....not sure how/why

Hi all, I had a wonderful bunch of code working perfectly on a project, but I have been asked to change the formatting and layout of the sheet and thought it would be easiest to create a new file and transfer sheet code across. In doing so, some of the functionality is not working and I can't...

www.mrexcel.com

Your code in both looks to be the same, so I suspect you are really asking the same question.
If so, you should continue in the original thread instead of starting a second thread for the same question.

MeaclH · Nov 6, 2024

Joe4 said:
Is this really the same question as your post from yesterday here?

Copied sheet code to new file and lost some functionality....not sure how/why

Hi all, I had a wonderful bunch of code working perfectly on a project, but I have been asked to change the formatting and layout of the sheet and thought it would be easiest to create a new file and transfer sheet code across. In doing so, some of the functionality is not working and I can't...

www.mrexcel.com

Your code in both looks to be the same, so I suspect you are really asking the same question.
If so, you should continue in the original thread instead of starting a second thread for the same question.

Hey Joe,
Yes, you're right. I wasn't sure what the issue was with the code, but since discovered it's the merged cells, hence the new question. My error.
Happy to have either question deleted if appropriate.

Cheers
Hayden

Joe4 · Nov 6, 2024

OK, I have merged your two threads, as per rule 12 here: Copied sheet code to new file and lost some functionality....not sure how/why

Regarding your question, I would very highly recommend getting rid of the merged cells if at all possible. Merged cells are perhaps the worst single feature of Excel, and cause all sorts of issues for things like VBA, sorting, etc.

If you are merging cells across single rows, you can get the exact same visual effect without all the issues by using the "Center Across Selection" formatting option instead of using merged cells.
See here: Tom’s Tutorials For Excel: Using Center Across Selection Instead of Merging Cells – Tom Urtis

MeaclH · Nov 6, 2024

Joe4 said:
OK, I have merged your two threads, as per rule 12 here: Copied sheet code to new file and lost some functionality....not sure how/why

Regarding your question, I would very highly recommend getting rid of the merged cells if at all possible. Merged cells are perhaps the worst single feature of Excel, and cause all sorts of issues for things like VBA, sorting, etc.

If you are merging cells across single rows, you can get the exact same visual effect without all the issues by using the "Center Across Selection" formatting option instead of using merged cells.
See here: Tom’s Tutorials For Excel: Using Center Across Selection Instead of Merging Cells – Tom Urtis

Thanks Joe! Appreciate the help and apologises for the double up. Noted for future.
Cheers

Copied sheet code to new file and lost some functionality....not sure how/why

MeaclH

Board Regular

Excel Facts

MeaclH

Board Regular

Joe4

MrExcel MVP, Junior Admin

Copied sheet code to new file and lost some functionality....not sure how/why

MeaclH

Board Regular

Copied sheet code to new file and lost some functionality....not sure how/why

Joe4

MrExcel MVP, Junior Admin

MeaclH

Board Regular

Similar threads

Forum statistics

Share this page

Copied sheet code to new file and lost some functionality....not sure how/why

Board Regular

Excel Facts

Board Regular

MrExcel MVP, Junior Admin

Board Regular

MrExcel MVP, Junior Admin

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock