Skip to content

Commit 1837487

Browse files
christwellmanchristwellman
committed
New OPRM reject outlook macro
1 parent ed3a146 commit 1837487

File tree

2 files changed

+284
-171
lines changed

2 files changed

+284
-171
lines changed

‎ProjectPipeline-WorksheetChangeEvents.vb

Lines changed: 195 additions & 171 deletions
Original file line numberDiff line numberDiff line change
@@ -17,9 +17,6 @@ Dim Brendon As Range
1717
Dim David As Range
1818
Dim Erik As Range
1919
Dim copyrange As Range
20-
dim UpdatedCell as Integer
21-
dim PracticeDM as String
22-
dim PIDStatus as string
2320

2421
Set ws0 = Sheets("LOVs")
2522
Set ws1 = Sheets("Project Pipeline")
@@ -34,180 +31,207 @@ Set ws8 = Sheets("Complete - Presales - Scoping")
3431
Set Scott = ws0.Range("ScottsTeam")
3532
Set Erik = ws0.Range("EriksTeam")
3633

37-
'**************************************************************
38-
ThisRow = Target.Row
39-
UpdatedCell = Target.Column
40-
Select Case UpdatedCell
41-
'PM assignement or Ready to staff determined by column "T" or 20
42-
Case 20
34+
35+
36+
'Automaticly move for staffing hinges on Column "R"
37+
If Target.Column = 20 Then
38+
ThisRow = Target.Row
39+
4340
assignedPM = Target.Value
44-
Select Case assingedPM
45-
Case VBNullString
46-
'If PM name is changed to blank to you want to clear the input data?
47-
m = MsgBox("Confirm clear PM assiged data?", vbYesNo + vbMsgBoxSetForeground, "Clear Assignement Data")
48-
If m = vbYes Then
41+
If assignedPM <> vbNullString Then
42+
43+
44+
ConfirmAssigned:
45+
'Test For Ready For Staffing
46+
If ActiveSheet.Cells(ThisRow, 20).Value = "Needs DCPM" Then
47+
48+
'Update Date Ready for Staffing
49+
If ActiveSheet.Cells(ThisRow, 50).Value = vbNullString Then
50+
ActiveSheet.Cells(ThisRow, 50).Value = Now()
51+
End If
52+
ActiveSheet.Cells(ThisRow, 35).Value = "Pipeline - Pending Assignment"
53+
54+
'Call Copy to
55+
ws1.Cells(ThisRow, 1).Resize(1, 52).Interior.ColorIndex = 43
56+
57+
58+
59+
'Test for Scott
60+
ElseIf (WorksheetFunction.CountIf(Scott, assignedPM) > 0) Then
61+
M = InputBox(Prompt:="Confirm Assignment time and move to Scott's Tab", Title:="Assign and Move", Default:=Now())
62+
If StrPtr(M) = 0 Then
63+
Target.Value = vbNullString
64+
Else
65+
If M = vbNullString Then
66+
GoTo ConfirmAssigned
67+
Else
68+
'Update DCPM Assigned Date
69+
If ActiveSheet.Cells(ThisRow, 38).Value = vbNullString Then
70+
ActiveSheet.Cells(ThisRow, 38).Value = M
71+
End If
72+
ActiveSheet.Cells(ThisRow, 35).Value = "Assigned"
73+
74+
'Call Copy to
75+
ws1.Cells(ThisRow, 1).Resize(1, 52).Copy
76+
77+
'find the last row on teh destination sheet
78+
moverow = Lastrow(ws3) + 1
79+
ws3.Cells(moverow, 1).PasteSpecial xlPasteAll
80+
81+
'Remove source row
82+
ws1.Cells(ThisRow, 1).EntireRow.Delete
83+
End If
84+
End If
85+
86+
'Test for Erik
87+
ElseIf (WorksheetFunction.CountIf(Erik, assignedPM) > 0) Then
88+
M = InputBox(Prompt:="Confirm Assignment time and move to Erik's Tab", Title:="Assign and Move", Default:=Now())
89+
If StrPtr(M) = 0 Then
90+
Target.Value = vbNullString
91+
Else
92+
If M = vbNullString Then
93+
GoTo ConfirmAssigned
94+
Else
95+
'Update DCPM Assigned Date
96+
If ActiveSheet.Cells(ThisRow, 38).Value = vbNullString Then
97+
ActiveSheet.Cells(ThisRow, 38).Value = M
98+
End If
99+
ActiveSheet.Cells(ThisRow, 35).Value = "Assigned"
100+
101+
'Call Copy to
102+
ws1.Cells(ThisRow, 1).Resize(1, 52).Copy
103+
104+
'find the last row on teh destination sheet
105+
moverow = Lastrow(ws4) + 1
106+
ws4.Cells(moverow, 1).PasteSpecial xlPasteAll
107+
108+
'Remove source row
109+
ws1.Cells(ThisRow, 1).EntireRow.Delete
110+
End If
111+
End If
112+
113+
End If
114+
Else
115+
M = MsgBox("Confirm clear PM assiged data?", vbYesNo + vbMsgBoxSetForeground, "Clear Assignement Data")
116+
If M = vbYes Then
49117
'Update DCPM Assigned Date
50118
ActiveSheet.Cells(ThisRow, 38).Value = ""
51119
ws1.Cells(ThisRow, 1).Resize(1, 52).Interior.ColorIndex = xlNone
52120
End If
53-
Case "Needs DCPM"
54-
'Project is ready for staffing
55-
' Update Ready for staffing date if its blank
56-
If ActiveSheet.Cells(ThisRow, 50).Value = vbNullString Then
57-
ActiveSheet.Cells(ThisRow, 50).Value = Now()
58-
End If
59-
'Update PM status
60-
ActiveSheet.Cells(ThisRow, 35).Value = "Pending Assignment"
61-
'Add Pretty color to indicate this ones ready
62-
ws1.Cells(ThisRow, 1).Resize(1, 52).Interior.ColorIndex = 43
63-
Case Else
64-
If (WorksheetFunction.CountIf(Scott, assignedPM) > 0) Then
65-
m = InputBox(Prompt:="Confirm Assignment time and move to Scott's Tab", Title:="Assign and Move", Default:=Now())
66-
If StrPtr(m) = 0 Then
67-
Target.Value = vbNullString
68-
Else
69-
If m = vbNullString Then
70-
GoTo ConfirmAssigned
71-
Else
72-
'Update DCPM Assigned Date
73-
If ActiveSheet.Cells(ThisRow, 38).Value = vbNullString Then
74-
ActiveSheet.Cells(ThisRow, 38).Value = m
75-
End If
76-
ActiveSheet.Cells(ThisRow, 21).Value = "Scott Milesnick"
77-
ActiveSheet.Cells(ThisRow, 35).Value = "Assigned"
78-
79-
'Call Copy to
80-
ws1.Cells(ThisRow, 1).Resize(1, 52).Copy
81-
82-
'find the last row on teh destination sheet
83-
moverow = Lastrow(ws3) + 1
84-
ws3.Cells(moverow, 1).PasteSpecial xlPasteAll
85-
86-
'Remove source row
87-
ws1.Cells(ThisRow, 1).EntireRow.Delete
88-
End If
89-
End If
90-
'Test for Erik
91-
ElseIf (WorksheetFunction.CountIf(Erik, assignedPM) > 0) Then
92-
m = InputBox(Prompt:="Confirm Assignment time and move to Erik's Tab", Title:="Assign and Move", Default:=Now())
93-
If StrPtr(m) = 0 Then
94-
Target.Value = vbNullString
95-
Else
96-
If m = vbNullString Then
97-
GoTo ConfirmAssigned
98-
Else
99-
'Update DCPM Assigned Date
100-
If ActiveSheet.Cells(ThisRow, 38).Value = vbNullString Then
101-
ActiveSheet.Cells(ThisRow, 38).Value = m
102-
End If
103-
ActiveSheet.Cells(ThisRow, 35).Value = "Assigned"
104-
ActiveSheet.Cells(ThisRow, 21).Value = "Erik Vogel"
105-
106-
'Call Copy to
107-
ws1.Cells(ThisRow, 1).Resize(1, 52).Copy
108-
109-
'find the last row on teh destination sheet
110-
moverow = Lastrow(ws4) + 1
111-
ws4.Cells(moverow, 1).PasteSpecial xlPasteAll
112-
113-
'Remove source row
114-
ws1.Cells(ThisRow, 1).EntireRow.Delete
115-
End If
116-
End If
117-
End If
118-
End Select
119-
'WOrksheet CHange events for PIDStatus Changes
120-
Case 7
121-
PIDStatus = Activesheet.Cells(thisrow,7).Value
122-
Select Case PIDStatus
123-
Case "Delivery Close"
124-
'Update Delivery Close Date
125-
ActiveSheet.Cells(ThisRow, 41).Value = Now()
126-
Case "Closed"
127-
m = MsgBox("Are you sure you want to move this to the 'Closed' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
128-
If m = vbYes Then
129-
130-
'Update Closed Date
131-
ActiveSheet.Cells(ThisRow, 42).Value = Now()
132-
133-
'Update DCPM Status
134-
ActiveSheet.Cells(ThisRow, 35).Value = "Closed"
135-
136-
'Find the last row on teh Closed Tab
137-
moverow = Lastrow(ws5) + 1
138-
139-
'copy used range in active row
140-
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
141-
ws5.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
142-
143-
'Remove source row
144-
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
145-
Else
146-
End If
147-
Case "Cancelled"
148-
m = MsgBox("Are you sure you want to move this to the 'Complete' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
149-
If m = vbYes Then
150-
151-
'Update Closed Date
152-
ActiveSheet.Cells(ThisRow, 42).Value = Now()
153-
154-
'Update DCPM Status
155-
ActiveSheet.Cells(ThisRow, 35).Value = "Cancelled"
156-
157-
'Find the last row on teh Closed Tab
158-
moverow = Lastrow(ws5) + 1
159-
160-
'copy used range in active row
161-
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
162-
ws8.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
163-
164-
'Remove source row
165-
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
166-
End If
167-
End Select
168-
'Worksheet Change Events for PM Status changes
169-
Case 35
170-
If ActiveSheet.Cells(ThisRow, 35).Value = "Complete - Presales Only" Or _
121+
End If
122+
End If
123+
'Exit Sub
124+
125+
'Move to Closed tab if PID is closed
126+
If Target.Column = 7 Then
127+
ThisRow = Target.Row
128+
129+
'Check to see if PID is Delivery Close
130+
If ActiveSheet.Cells(ThisRow, 7).Value = "Delivery Close" Then
131+
132+
'Update Delivery Close Date
133+
ActiveSheet.Cells(ThisRow, 41).Value = Now()
134+
135+
ElseIf ActiveSheet.Cells(ThisRow, 7).Value = "Closed" Then
136+
M = MsgBox("Are you sure you want to move this to the 'Closed' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
137+
If M = vbYes Then
138+
139+
'Update Closed Date
140+
ActiveSheet.Cells(ThisRow, 42).Value = Now()
141+
142+
'Update DCPM Status
143+
ActiveSheet.Cells(ThisRow, 35).Value = "Closed"
144+
145+
'Find the last row on teh Closed Tab
146+
moverow = Lastrow(ws5) + 1
147+
148+
'copy used range in active row
149+
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
150+
ws5.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
151+
152+
'Remove source row
153+
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
154+
Else
155+
156+
End If
157+
ElseIf ActiveSheet.Cells(ThisRow, 7).Value = "Cancelled" Then
158+
M = MsgBox("Are you sure you want to move this to the 'Complete' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
159+
If M = vbYes Then
160+
161+
'Update Closed Date
162+
ActiveSheet.Cells(ThisRow, 42).Value = Now()
163+
164+
'Update DCPM Status
165+
ActiveSheet.Cells(ThisRow, 35).Value = "Cancelled"
166+
167+
'Find the last row on teh Closed Tab
168+
moverow = Lastrow(ws5) + 1
169+
170+
'copy used range in active row
171+
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
172+
ws8.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
173+
174+
'Remove source row
175+
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
176+
177+
ElseIf M = vbNo Then Exit Sub
178+
179+
End If
180+
181+
End If
182+
183+
End If
184+
185+
'PM Status Changes
186+
If Target.Column = 35 Then
187+
ThisRow = Target.Row
188+
189+
If ActiveSheet.Cells(ThisRow, 35).Value = "Complete - Presales Only" Or _
171190
ActiveSheet.Cells(ThisRow, 35).Value = "Complete - Handled out of Practice" Or _
172191
ActiveSheet.Cells(ThisRow, 35).Value = "Complete - DCV work finished" Then
173-
m = MsgBox("Are you sure you want to move this to the 'Complete' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
174-
If m = vbYes Then
175-
176-
'Update Closed Date
177-
ActiveSheet.Cells(ThisRow, 42).Value = Now()
178-
179-
'Update DCPM Status
180-
ActiveSheet.Cells(ThisRow, 35).Value = "Complete"
181-
182-
'Find the last row on teh Closed Tab
183-
moverow = Lastrow(ws8) + 1
184-
185-
'copy used range in active row
186-
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
187-
ws8.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
188-
189-
'Remove source row
190-
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
191-
End If
192-
End If
193-
194-
Case Else
192+
M = MsgBox("Are you sure you want to move this to the 'Complete' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
193+
If M = vbYes Then
195194

196-
End Select
197-
198-
199-
200-
'***************************************************************
201-
End Sub
195+
'Update Closed Date
196+
ActiveSheet.Cells(ThisRow, 42).Value = Now()
197+
198+
'Update DCPM Status
199+
ActiveSheet.Cells(ThisRow, 35).Value = "Complete"
200+
201+
'Find the last row on teh Closed Tab
202+
moverow = Lastrow(ws8) + 1
203+
204+
'copy used range in active row
205+
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
206+
ws8.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
207+
208+
'Remove source row
209+
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
210+
End If
211+
212+
ElseIf ActiveSheet.Cells(ThisRow, 35).Value = "Cold" Or _
213+
ActiveSheet.Cells(ThisRow, 35).Value = "Duplicate Request" Or _
214+
ActiveSheet.Cells(ThisRow, 35).Value = "Cancelled" Then
215+
M = MsgBox("Are you sure you want to move this to the 'Complete' tab?", vbYesNo + vbMsgBoxSetForeground, "Move Project?")
216+
If M = vbYes Then
217+
218+
'Update Closed Date
219+
ActiveSheet.Cells(ThisRow, 42).Value = Now()
220+
221+
'Update DCPM Status
222+
ActiveSheet.Cells(ThisRow, 35).Value = "Complete"
223+
224+
'Find the last row on teh Closed Tab
225+
moverow = Lastrow(ws8) + 1
226+
227+
'copy used range in active row
228+
ActiveSheet.Cells(ThisRow, 1).Resize(1, 52).Copy
229+
ws8.Cells(moverow, 1).PasteSpecial xlPasteAllExceptBorders
230+
231+
'Remove source row
232+
ActiveSheet.Cells(ThisRow, 1).EntireRow.Delete
233+
End If
234+
End If
235+
End If
202236

203-
Function Lastrow(Sh As Worksheet)
204-
On Error Resume Next
205-
Lastrow = Sh.Cells.Find(What:="*", _
206-
After:=Sh.Range("A1"), _
207-
LookAt:=xlPart, _
208-
LookIn:=xlFormulas, _
209-
SearchOrder:=xlByRows, _
210-
SearchDirection:=xlPrevious, _
211-
MatchCase:=False).Row
212-
On Error GoTo 0
213-
End Function
237+
End Sub

0 commit comments

Comments
 (0)