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
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
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
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