Worksheet change event using a button

Hi gurus..

The attached workbook has multiple macros. All macros works as intended. Neeraj from this site helped me with the change vent macros.  Requesting a change in the worksheet change event macro.

This is a suggestion from the users of the worksheet.

Instead of allocating each task, users are suggesting first to select the Planners from the drop down list in column N and after completing the selection, click the ''allocate task'' button to send all the tasks in one go.

Not sure whether to separate the auto date population macro, if task allocation macro need to undergo major changes.

Regards
Team-2.xlsm
Matt MaliAsked:
Who is Participating?
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Hi Matt,

I have replace the Sheet Change Event with the following code.

Sheet Change Event Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long
    If Target.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("C6:C" & Range("C" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        r = Target.Row
        If Target <> "" Then
            Application.EnableEvents = False
            If Cells(r, "L") = "" Then
                Cells(r, "L").NumberFormat = "dd/mm/yyyy"
                Cells(r, "L") = Now
            End If
            Application.EnableEvents = True
        End If
    End If
Application.ScreenUpdating = True
End Sub

Open in new window


I have placed a code called "AllocateTasks" on Module1 and assigned this code to the button "Allocate Tasks". You may click this button to run the code.

Code on Module1:

Sub AllocateTasks()
Dim swb As Workbook, dwb2 As Workbook
Dim sws As Worksheet, dws2 As Worksheet
Dim dwbPath As String, Team As String, TeamNo As String, Task As String
Dim lr As Long, i As Long

Application.ScreenUpdating = False

Set swb = ThisWorkbook
Set sws = swb.Sheets("Task Allocation")
lr = sws.Cells(Rows.Count, "N").End(xlUp).Row
If lr < 6 Then
    MsgBox "No Tasks were found to be allocated.", vbExclamation, "Tasks Not Found!"
    Exit Sub
End If

For i = lr To 6 Step -1
    If sws.Cells(i, "N").Value <> "" Then
        Task = sws.Cells(i, "N").Value
        TeamNo = ExtractNumber(Task)
        dwbPath = "C:\Secured\Planner Level\Planner " & TeamNo & "\Planner " & TeamNo & ".xlsm"
        On Error Resume Next
        Set dwb2 = Workbooks("Planner " & TeamNo & ".xlsm")
        On Error GoTo 0
    
        If dwb2 Is Nothing And Dir(dwbPath) <> "" Then
            Set dwb2 = Workbooks.Open(dwbPath, False)
        End If
        
        If Not dwb2 Is Nothing Then
            Set dws2 = dwb2.Sheets(1)
            sws.Range("C" & i & ":K" & i).Copy
            dws2.Range("C" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
            sws.Range("C" & i & ":O" & i).Delete shift:=xlUp
        End If
    End If
Next i
End Sub

Open in new window


Please find the attached for your reference.
Team-3.xlsm
0
 
Matt MaliAuthor Commented:
Thank you very much Neeraj.. Wasnt able to try the macro yet.. Down with flu..will let you know soon
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
No problem Matt! Take proper rest and get well soon.
0
Cloud Class® Course: CompTIA Cloud+

The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.

 
Matt MaliAuthor Commented:
Thanks Neeraj..The macros are working in my home computer. However when I try to do this in the office setting, a pop up box asking me to unprotect the destination sheet. The destination sheet vba can be found in

https://www.experts-exchange.com/questions/29098093/Autopopulating-cells-not-working-in-different-situations.html

The vba in the destination sheet should be unprotecting the sheet by itself which is not working in this situation.

Any thoughts??
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Which code is not working if the sheet is protected? Is it writing the date in column L or transferring the data into other workbook?

If this is sheet change event, please replace the sheet change event code with the following one and change the password in line#1.
Const PW As String = "Matt"
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long
    If Target.CountLarge > 1 Then Exit Sub
    ThisWorkbook.ActiveSheet.Unprotect PW
    If Not Intersect(Target, Range("C6:C" & Range("C" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        r = Target.Row
        If Target <> "" Then
            Application.EnableEvents = False
            If Cells(r, "L") = "" Then
                Cells(r, "L").NumberFormat = "dd/mm/yyyy"
                Cells(r, "L") = Now
            End If
            Application.EnableEvents = True
        End If
    End If
    ThisWorkbook.ActiveSheet.Protect PW
Application.ScreenUpdating = True
End Sub

Open in new window

0
 
Matt MaliAuthor Commented:
Thanks Neeraj. Transferring the data into other workbook is not working. Tasks are not moving from the Team level to the employee level. Whenever task allocation button is pressed, a pop up box will come up as a runtime error asking to unprotect  the employee level sheet.

In the above macro, the sheet hiding change based on criteria is not included.

Const PW As String = "Matt"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Long
Dim cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Skip
ThisWorkbook.ActiveSheet.Unprotect PW
If Not Intersect(Target, Range("C6:C3000")) Is Nothing Then
    For Each cell In Target.Columns(1).Cells
        r = cell.Row
        If Cells(r, "C") <> "" Then
            If Cells(r, "L") = "" Then
                Cells(r, "L").NumberFormat = "dd/mm/yyyy"
                Cells(r, "L") = Now
            End If
        End If
    Next cell
ElseIf Not Intersect(Target, Range("AA6:AA3000")) Is Nothing Then
    If Target <> "" Then
        If LCase(Target.Value) = "completed" Then
            Target.EntireRow.Hidden = True
        End If
    End If
End If
ThisWorkbook.ActiveSheet.Protect PW
Skip:
Application.EnableEvents = True
End Sub

Open in new window


This was the code previously sent by you.
With my limited knowledge, I have added the added the second change event in to your new code as follows

Const PW As String = "Matt"
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long
    If Target.CountLarge > 1 Then Exit Sub
    ThisWorkbook.ActiveSheet.Unprotect PW
    If Not Intersect(Target, Range("C6:C" & Range("C" & Rows.Count).End(xlUp).Row)) Is Nothing Then
        r = Target.Row
        If Target <> "" Then
            Application.EnableEvents = False
            If Cells(r, "L") = "" Then
                Cells(r, "L").NumberFormat = "dd/mm/yyyy"
                Cells(r, "L") = Now
            End If
            Application.EnableEvents = True
        End If
    End If
    Next cell
ElseIf Not Intersect(Target, Range("AA6:AA”& Range("AA" & Rows.Count).End(xlUp).Row)) Is Nothing Then
    If Target <> "" Then
        If LCase(Target.Value) = "completed" Then
            Target.EntireRow.Hidden = True
        End If
    End If
End If
ThisWorkbook.ActiveSheet.Protect PW
Application.ScreenUpdating = True
End Sub

Open in new window


Please let me know if I am doing it right.

Regards
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Earlier you said that you don't need the hide functionality in the sheet change event and requested to delete it. Isn't it?

Anyways, it seems you tweaked it correctly. Did you not test it after tweaking it?

Also, if the unprotect prompt is being appeared when you transfer the data to another workbook. The code which handles this functionality is placed on Module1 and called "AllocateTasks" which you run by hitting a button.

All you need is, replace the existing code "AllocateTasks" on Module1 with the following one. See if that works for you.
Const PW As String = "Matt"
Sub AllocateTasks()
Dim swb As Workbook, dwb2 As Workbook
Dim sws As Worksheet, dws2 As Worksheet
Dim dwbPath As String, Team As String, TeamNo As String, Task As String
Dim lr As Long, i As Long

Application.ScreenUpdating = False

Set swb = ThisWorkbook
Set sws = swb.Sheets("Task Allocation")
lr = sws.Cells(Rows.Count, "N").End(xlUp).Row
If lr < 6 Then
    MsgBox "No Tasks were found to be allocated.", vbExclamation, "Tasks Not Found!"
    Exit Sub
End If

For i = lr To 6 Step -1
    If sws.Cells(i, "N").Value <> "" Then
        Task = sws.Cells(i, "N").Value
        TeamNo = ExtractNumber(Task)
        dwbPath = "C:\Secured\Planner Level\Planner " & TeamNo & "\Planner " & TeamNo & ".xlsm"
        On Error Resume Next
        Set dwb2 = Workbooks("Planner " & TeamNo & ".xlsm")
        On Error GoTo 0
    
        If dwb2 Is Nothing And Dir(dwbPath) <> "" Then
            Set dwb2 = Workbooks.Open(dwbPath, False)
        End If
        
        If Not dwb2 Is Nothing Then
            Set dws2 = dwb2.Sheets(1)
            dws2.Unprotect PW
            sws.Range("C" & i & ":K" & i).Copy
            dws2.Range("C" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
            sws.Range("C" & i & ":O" & i).Delete shift:=xlUp
        End If
    End If
Next i
dws2.Protect PW
End Sub

Open in new window

0
 
Matt MaliAuthor Commented:
Thanks Neeraj. My tweaked code is showing a Compile error-Next Without For. Not sure what to do
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Remove line#17 from your tweaked code i.e. remove Next cell
0
 
Matt MaliAuthor Commented:
Thanks Neeraj. I removed the password option and is working well. I think I should leave it that way. Thanks heaps for all your advice and input.
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Matt! Glad your issue is resolved.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.