Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!
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
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
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi Matt,
I have replace the Sheet Change Event with the following code.
Sheet Change Event Code:
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:
Please find the attached for your reference.
Team-3.xlsm
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
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
Please find the attached for your reference.
Team-3.xlsm
Thank you very much Neeraj.. Wasnt able to try the macro yet.. Down with flu..will let you know soon
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??
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??
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.
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
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.
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
Please let me know if I am doing it right.
Regards
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
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
Please let me know if I am doing it right.
Regards
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.
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
Premium Content
You need an Expert Office subscription to comment.Start Free Trial