API tools faq
paste
Guest User

Untitled

a guest
Dec 6th, 2017
86
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 32.43 KB | None | 0 0
raw download clone embed print report
  1. Public Declare Function sndPlaySound32 _
  2. Lib "winmm.dll" _
  3. Alias "sndPlaySoundA" ( _
  4. ByVal lpszSoundName As String, _
  5. ByVal uFlags As Long) As Long
  6. Option Explicit
  7. Dim findVal, findVal2, storageRangeCells, user, rn, _
  8. archiveStatusListRange, accessLevelListRange, _
  9. changeArchiveStatus, oldArchiveStatus, newArchiveStatus, _
  10. changeAccessLevel, oldAccessLevel, newAccessLevel, _
  11. cellVal, toprow, containerRangeCells, cellTest, updateCell As Range
  12. Dim novaBook, WbkCheck, progWb, MyBook As Workbook
  13. Dim wsSource, wsInput, wsSetup, wsToDoList, Sheet As Worksheet
  14. Dim gridType, updateFlag, saveBackup As Boolean
  15. Dim dodgyFlag, i, LRT, LRC, LR, LRBackup, countDone, _
  16. accessionCol, TitleCol, archiveNotesCol, issueDateCol, _
  17. retCatCol, storageSiteCol, authorCol, mudCol, rprdCol, _
  18. rpsdeCol, rpsdCol, archLocCol, archStatusCol, accessLevel, _
  19. dave, archiveStatusFlag, rowNumber, applicationCol As Byte
  20. Dim answer As Variant
  21. Dim filepaths As String
  22. Dim bigDate As Date
  23. Sub Macro()
  24. Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
  25. Set wsSource = novaBook.Worksheets("Source")
  26. Set wsInput = novaBook.Worksheets("Input")
  27. Set wsSetup = novaBook.Worksheets("Setup")
  28. Set wsToDoList = novaBook.Worksheets("ToDoList")
  29. Set archiveStatusListRange = wsSource.Range("D2:D16")
  30. Set accessLevelListRange = wsSource.Range("E2:E17")
  31. Set changeArchiveStatus = wsSetup.Range("H22")
  32. Set oldArchiveStatus = wsSetup.Range("H25")
  33. Set newArchiveStatus = wsSetup.Range("I25")
  34. Set changeAccessLevel = wsSetup.Range("H29")
  35. Set oldAccessLevel = wsSetup.Range("H32")
  36. Set newAccessLevel = wsSetup.Range("I32")
  37. If wsInput.Range("A1").Value = "" Then GoTo wrongPlace
  38. Call startNoUpdates '******************************************************************* INITIAL SETUP STEPS
  39. Workbooks.Open Filename:="R:NovartisMetadata Update Progress TrackerMetadata Update Progress Tracker.xlsx"
  40. Set progWb = Workbooks("Metadata Update Progress Tracker.xlsx")
  41. gridType = 0
  42. updateFlag = 0
  43. archiveStatusFlag = 0
  44. dodgyFlag = 0
  45. wsSetup.Activate
  46. wsSetup.Unprotect Password:="spectrum19"
  47. With changeArchiveStatus.Validation ' SET DATA VALIDATION FOR CHANGE ARCHIVE STATUS
  48. .Delete
  49. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  50. Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
  51. End With
  52. With oldArchiveStatus.Validation ' SET DATA VALIDATION FOR OLD ARCHIVE STATUS
  53. .Delete
  54. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  55. Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
  56. End With
  57. With newArchiveStatus.Validation ' SET DATA VALIDATION FOR NEW ARCHIVE STATUS
  58. .Delete
  59. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  60. Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
  61. End With
  62. With changeAccessLevel.Validation ' SET DATA VALIDATION FOR CHANGE ACCESS LEVEL
  63. .Delete
  64. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  65. Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
  66. End With
  67. With oldAccessLevel.Validation ' SET DATA VALIDATION FOR OLD ACCESS LEVEL
  68. .Delete
  69. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  70. Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
  71. End With
  72. With newAccessLevel.Validation ' SET DATA VALIDATION FOR NEW ACCESS LEVEL
  73. .Delete
  74. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  75. Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
  76. End With
  77. wsSetup.Protect Password:="spectrum19"
  78. Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Input").Activate
  79. LR = Cells(Rows.Count, 3).End(xlUp).Row ' DEFINE LAST ROW
  80. If Range("B1").Value = "Title" Then gridType = 1 ' SET BOOLEAN FOR MULTIEDIT/INFOTYPE MODE
  81. If Len(Dir("u:Novartis Backup", vbDirectory)) = 0 Then MkDir "u:Novartis Backup"
  82. i = 1
  83. saveBackup = False
  84. Do While saveBackup = False ' MAKE BACKUP WORKBOOK
  85. filepaths = "u:Novartis Backupbackup" & i & ".xlsx"
  86. If Dir(filepaths) = "" Then
  87. Set MyBook = Workbooks.Add
  88. With MyBook
  89. .Title = "backup"
  90. .SaveAs Filename:="u:Novartis Backupbackup" & i & ".xlsx"
  91. .Sheets.Add.Name = "Multiedit_Backup"
  92. .Sheets.Add.Name = "Grid_Backup"
  93. Worksheets("Multiedit_Backup").Move Before:=ActiveWorkbook.Sheets(1)
  94. End With
  95. Workbooks("backup" & i & ".xlsx").Activate
  96. SheetKiller ("Sheet1")
  97. saveBackup = True
  98. Else: i = i + 1
  99. End If
  100. Loop
  101. Set WbkCheck = ActiveWorkbook
  102. Select Case True
  103. Case gridType = 1
  104. LRBackup = WbkCheck.Worksheets("Multiedit_Backup").Cells(Rows.Count, 1).End(xlUp).Row ' FIND LAST ROW ON NEW SHEET
  105. If LRBackup = 1 Then ' ADD DATA TO Multiedit_Backup
  106. wsInput.Range("A1:AU" & LR).Copy Destination:=WbkCheck.Worksheets("Multiedit_Backup").Cells(LRBackup, 1)
  107. Else
  108. wsInput.Range("A1:AU" & LR).Copy Destination:=WbkCheck.Worksheets("Multiedit_Backup").Cells(LRBackup + 1, 1)
  109. End If
  110. Case gridType = 0
  111. LRBackup = WbkCheck.Worksheets("Grid_Backup").Cells(Rows.Count, 1).End(xlUp).Row ' FIND LAST ROW ON NEW SHEET
  112. If LRBackup = 1 Then ' ADD DATA TO Grid_Backup
  113. wsInput.Range("A1:G" & LR).Copy Destination:=WbkCheck.Worksheets("Grid_Backup").Cells(LRBackup, 1)
  114. Else
  115. wsInput.Range("A1:G" & LR).Copy Destination:=WbkCheck.Worksheets("Grid_Backup").Cells(LRBackup + 1, 1)
  116. End If
  117. End Select
  118. ActiveWorkbook.Save ' SAVE & CLOSE BACKUP
  119. ActiveWorkbook.Close
  120. novaBook.Worksheets("Input").Activate
  121. If gridType = 1 Then ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
  122. Set containerRangeCells = Range("Z2:Z" & LR)
  123. End If
  124. If gridType = 0 Then ' SET CONTAINER RANGE FOR INFOTYPE GRID MODE
  125. Set containerRangeCells = Range("D2:D" & LR)
  126. End If
  127. If Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Setup").ArchiveLocToggle1.Value = True Then 'UPDATE ARCHIVE LOCATION USING CONTAINER NUM AS REF
  128. For Each cellVal In containerRangeCells
  129. Set findVal = Worksheets("Source").Range("A1:B13676").Find(cellVal, LookAt:=xlWhole)
  130. If Not findVal Is Nothing Then
  131. cellVal.Offset(0, 1).Value = findVal.Offset(0, 1)
  132. cellVal.Offset(0, 1).Interior.ColorIndex = 4
  133. findVal.Interior.ColorIndex = xlNone
  134. findVal.Interior.Color = vbMagenta
  135. If gridType = 1 Then ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
  136. cellVal.Offset(0, -26).Interior.ColorIndex = vbMagenta
  137. End If
  138. End If
  139. Next cellVal
  140. On Error GoTo 0
  141. End If
  142. If Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Setup").ContainerNumToggle2.Value = True Then ' UPDATE CONTAINER NUMBER FROM OLD TO NEW
  143. For Each cellVal In containerRangeCells
  144. Set findVal = Worksheets("Source").Range("A1:B13676").Find(cellVal, LookAt:=xlWhole)
  145. If Not findVal Is Nothing Then
  146. cellVal.Value = findVal.Offset(0, 1)
  147. cellVal.Interior.ColorIndex = 4
  148. findVal.Interior.ColorIndex = xlNone
  149. findVal.Interior.Color = vbMagenta
  150. If gridType = 1 Then ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
  151. cellVal.Offset(0, -26).Interior.ColorIndex = vbMagenta
  152. End If
  153. End If
  154. Next cellVal
  155. On Error GoTo 0
  156. End If
  157. Set toprow = novaBook.Worksheets("Input").Range("1:1")
  158. Select Case True
  159. Case gridType = 0
  160. Call infoTypeGridMode
  161. Case gridType = 1
  162. Call multieditGridMode
  163. End Select
  164. Call endNoUpdates
  165. Call ResetFind
  166. wsInput.Activate
  167. If gridType = 1 Then ' COPY SHEET
  168. wsInput.Range("A2:AU" & LR).Select
  169. Else
  170. wsInput.Range("A2:G" & LR).Select
  171. End If
  172. Selection.Copy
  173. sndPlaySound32 "C:WindowsMediaCityscapeWindows Balloon.wav", 0&
  174. Exit Sub '***************************************************************************************************END OF MAIN LINE
  175. wrongPlace:
  176. Call endNoUpdates
  177. Call ResetFind
  178. MsgBox "You appear to have pasted the information in the wrong place." & vbNewLine & "Bloody hell man, get it together!" & vbNewLine & "Stick it in A1!", 48, "Copy & Paste Error"
  179. Exit Sub
  180. End Sub
  181. Sub multieditGridMode() '****************************************************MULTIEDIT GRID MODE
  182. Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
  183. Set wsSource = novaBook.Worksheets("Source")
  184. Set wsInput = novaBook.Worksheets("Input")
  185. Set wsSetup = novaBook.Worksheets("Setup")
  186. Set wsToDoList = novaBook.Worksheets("ToDoList")
  187. Set archiveStatusListRange = wsSource.Range("D2:D16")
  188. Set accessLevelListRange = wsSource.Range("E2:E17")
  189. Set changeArchiveStatus = wsSetup.Range("H22")
  190. Set oldArchiveStatus = wsSetup.Range("H25")
  191. Set newArchiveStatus = wsSetup.Range("I25")
  192. Set changeAccessLevel = wsSetup.Range("H29")
  193. Set oldAccessLevel = wsSetup.Range("H32")
  194. Set newAccessLevel = wsSetup.Range("I32")
  195. novaBook.Activate
  196. wsInput.Activate
  197. LR = Cells(Rows.Count, 3).End(xlUp).Row
  198. For dave = 2 To LR ' CHECK FOR CARRAIGE RETURNS
  199. Set cellTest = wsInput.Range("A" & dave)
  200. If Not IsNumeric(cellTest) Then
  201. GoTo carraigeReturnDetected
  202. End If
  203. Next dave
  204. Set toprow = novaBook.Worksheets("Input").Range("1:1")
  205. On Error GoTo noHeader
  206. accessionCol = toprow.Find("Accession Number", LookAt:=xlWhole).Column
  207. TitleCol = toprow.Find("Title", LookAt:=xlWhole).Column
  208. archiveNotesCol = toprow.Find("Archive Notes", LookAt:=xlWhole).Column
  209. issueDateCol = toprow.Find("Issue Date", LookAt:=xlWhole).Column
  210. retCatCol = toprow.Find("Record Retention Category", LookAt:=xlWhole).Column
  211. storageSiteCol = toprow.Find("Storage Site", LookAt:=xlWhole).Column
  212. authorCol = toprow.Find("Author", LookAt:=xlWhole).Column
  213. mudCol = toprow.Find("Author ID ", LookAt:=xlWhole).Column
  214. rpsdCol = toprow.Find("Retention Period Start Date", LookAt:=xlWhole).Column
  215. rprdCol = toprow.Find("Retention Review Date", LookAt:=xlWhole).Column
  216. rpsdeCol = toprow.Find("Retention Period Start Date Event", LookAt:=xlWhole).Column
  217. archLocCol = toprow.Find("Archive Location", LookAt:=xlWhole).Column
  218. archStatusCol = toprow.Find("Archive Status", LookAt:=xlWhole).Column
  219. accessLevel = toprow.Find("Access Level", LookAt:=xlWhole).Column
  220. applicationCol = toprow.Find("Application Name", LookAt:=xlWhole).Column
  221.  
  222. On Error GoTo 0
  223. For rowNumber = 2 To LR
  224. If novaBook.Worksheets("Setup").TitleOption1.Value = True And Worksheets("Setup").TextBox1.Value <> "" Then ' AMEND TITLE
  225. wsInput.Cells(rowNumber, TitleCol).Value = Worksheets("Setup").TextBox1.Value & " - " & Cells(2, TitleCol).Value
  226. wsInput.Cells(rowNumber, TitleCol).Interior.Color = vbGreen
  227. updateFlag = 1
  228. End If
  229. If novaBook.Worksheets("Setup").TitleOption2.Value = True And Worksheets("Setup").TextBox1.Value <> "" Then ' REPLACE TITLE
  230. wsInput.Cells(rowNumber, TitleCol).Value = Worksheets("Setup").TextBox1.Value
  231. wsInput.Cells(rowNumber, TitleCol).Interior.Color = vbGreen
  232. updateFlag = 1
  233. End If
  234. If novaBook.Worksheets("Setup").NotesButton1.Value = True And Worksheets("Setup").TextBox7.Value <> "" Then ' AMEND ARCHIVE NOTES
  235. wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox7.Value & " - " & Cells(rowNumber, archiveNotesCol).Value
  236. wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
  237. updateFlag = 1
  238. End If
  239. If novaBook.Worksheets("Setup").NotesButton2.Value = True And Worksheets("Setup").TextBox7.Value <> "" Then ' REPLACE ARCHIVE NOTES
  240. wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox7.Value
  241. wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
  242. updateFlag = 1
  243. End If
  244. If Worksheets("Setup").Remove1.Value Then ' REMOVE ARCHIVE LOCATION
  245. wsInput.Cells(rowNumber, archLocCol).Clear
  246. wsInput.Cells(rowNumber, archLocCol).Interior.Color = vbGreen
  247. updateFlag = 1
  248. End If
  249. If wsInput.Cells(LR, applicationCol).Value = "PD Shelf Life System" Then ' MOVE BAD APPLICATION NAME
  250. wsInput.Cells(LR, applicationCol).Value = ""
  251. wsInput.Cells(LR, applicationCol).Offset(0, -3).Value = "PD Shelf Life System"
  252. wsInput.Cells(LR, applicationCol).Interior.Color = vbMagenta
  253. wsInput.Cells(LR, applicationCol).Offset(0, -3).Interior.Color = vbMagenta
  254. End If
  255. If Worksheets("Setup").Remove2.Value Then ' REMOVE MUD ID
  256. wsInput.Cells(rowNumber, mudCol).Clear
  257. wsInput.Cells(rowNumber, mudCol).Interior.Color = vbGreen
  258. updateFlag = 1
  259. End If
  260. If Worksheets("Setup").TextBox2.Text <> "" Then ' NEW AUTHOR
  261. wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox2.Text
  262. wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
  263. updateFlag = 1
  264. End If
  265. If Worksheets("Setup").TextBox3.Text <> "" Then ' NEW MUD ID
  266. wsInput.Cells(rowNumber, mudCol).Value = Worksheets("Setup").TextBox3.Text
  267. wsInput.Cells(rowNumber, mudCol).Interior.Color = vbGreen
  268. updateFlag = 1
  269. End If
  270. If Worksheets("Setup").TextBox4.Text <> "" Then ' NEW RPSD
  271. wsInput.Cells(rowNumber, rpsdCol).Value = Worksheets("Setup").TextBox4.Text
  272. wsInput.Cells(rowNumber, rpsdCol).Interior.Color = vbGreen
  273. updateFlag = 1
  274. End If
  275. If Worksheets("Setup").TextBox5.Text <> "" Then ' NEW RPRD
  276. wsInput.Cells(rowNumber, rprdCol).Value = Worksheets("Setup").TextBox5.Text
  277. wsInput.Cells(rowNumber, rprdCol).Interior.Color = vbGreen
  278. updateFlag = 1
  279. End If
  280. If Worksheets("Setup").TextBox6.Text <> "" Then ' NEW RPSDE
  281. wsInput.Cells(rowNumber, rpsdeCol).Value = Worksheets("Setup").TextBox6.Text
  282. wsInput.Cells(rowNumber, rpsdeCol).Interior.Color = vbGreen
  283. updateFlag = 1
  284. End If
  285. If Worksheets("Setup").Range("newRetCatRng").Value <> "" Then ' NEW RETENTION CAT.
  286. wsInput.Cells(rowNumber, retCatCol).Value = Range("newRetCatRng").Value
  287. wsInput.Cells(rowNumber, retCatCol).Interior.Color = vbGreen
  288. updateFlag = 1
  289. End If
  290. If Worksheets("Setup").TextBox8.Value <> "" Then ' NEW ISSUE DATE
  291. wsInput.Cells(rowNumber, issueDateCol).Value = Worksheets("Setup").TextBox8.Value
  292. wsInput.Cells(rowNumber, issueDateCol).Interior.Color = vbGreen
  293. updateFlag = 1
  294. End If
  295. If Worksheets("Setup").Storage2.Value = True Then ' REPLACE STORAGE SITE WITH STEVENAGE
  296. wsInput.Cells(rowNumber, storageSiteCol).Value = "Stevenage"
  297. wsInput.Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
  298. updateFlag = 1
  299. End If
  300. If Worksheets("Setup").Storage3.Value = True Then ' REPLACE STORAGE SITE WITH RECALL UK
  301. Cells(rowNumber, storageSiteCol).Value = "Recall UK"
  302. Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
  303. updateFlag = 1
  304. End If
  305. If Worksheets("Setup").Storage4.Value = True Then ' REPLACE STORAGE SITE WITH BLANK
  306. wsInput.Cells(rowNumber, storageSiteCol).Value = ""
  307. wsInput.Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
  308. updateFlag = 1
  309. End If
  310. Select Case True
  311. Case Worksheets("Setup").accessLevelButton1.Value = True ' FIND AND REPLACE ACCESS LEVEL
  312. If oldAccessLevel.Value <> "" = True And newAccessLevel.Value <> "" = True Then
  313. If Cells(rowNumber, accessLevel).Value = oldAccessLevel.Value Then
  314. wsInput.Cells(rowNumber, accessLevel).Value = newAccessLevel.Value
  315. wsInput.Cells(rowNumber, accessLevel).Interior.Color = vbGreen
  316. updateFlag = 1
  317. End If
  318. End If
  319. Case Worksheets("Setup").accessLevelButton1.Value = False
  320. If changeAccessLevel.Value <> "" Then ' CHANGE ACCESS LEVEL
  321. wsInput.Cells(rowNumber, accessLevel).Value = changeAccessLevel.Value
  322. wsInput.Cells(rowNumber, accessLevel).Interior.Color = vbGreen
  323. updateFlag = 1
  324. End If
  325. End Select
  326. Select Case True ' ARCHIVE STATUS
  327. Case Worksheets("Setup").archiveStatusButton1.Value = True
  328. If oldArchiveStatus.Value <> "" = True And newArchiveStatus.Value <> "" = True Then ' FIND AND REPLACE ARCHIVE STATUS
  329. Select Case True
  330. Case oldArchiveStatus = "Archived" ' CHANGING FROM ARCHIVED
  331. Select Case True
  332. Case newArchiveStatus = "Archived"
  333. archiveStatusFlag = 0
  334. Case newArchiveStatus = "Delete from database"
  335. archiveStatusFlag = 1
  336. Case newArchiveStatus = "Destroyed"
  337. archiveStatusFlag = 2
  338. Case newArchiveStatus = "Draft"
  339. archiveStatusFlag = 1
  340. Case newArchiveStatus = "Frozen"
  341. archiveStatusFlag = 1
  342. Case newArchiveStatus = "In Review"
  343. archiveStatusFlag = 1
  344. Case newArchiveStatus = "Missing"
  345. archiveStatusFlag = 0
  346. Case newArchiveStatus = "Rejected"
  347. archiveStatusFlag = 1
  348. Case newArchiveStatus = "Transferred outside GSK R&D"
  349. archiveStatusFlag = 0
  350. Case newArchiveStatus = "Withdrawn"
  351. archiveStatusFlag = 0
  352. Case newArchiveStatus = "DELETE"
  353. archiveStatusFlag = 1
  354. Case newArchiveStatus = "DESTROYED(Dup)"
  355. archiveStatusFlag = 1
  356. Case newArchiveStatus = "MISSING(Dup)"
  357. archiveStatusFlag = 1
  358. Case newArchiveStatus = "TRANSFERRED(Dup)"
  359. archiveStatusFlag = 1
  360. Case newArchiveStatus = "WITHDRAWN(Dup)"
  361. archiveStatusFlag = 1
  362. End Select
  363. Case oldArchiveStatus = "Withdrawn" ' CHANGING FROM WITHDRAWN
  364. Select Case True
  365. Case newArchiveStatus = "Archived"
  366. archiveStatusFlag = 2
  367. Case newArchiveStatus <> "Archived"
  368. archiveStatusFlag = 1
  369. End Select
  370. Case oldArchiveStatus = "Missing" ' CHANGING FROM MISSING
  371. Select Case True
  372. Case newArchiveStatus = "Archived"
  373. archiveStatusFlag = 2
  374. Case newArchiveStatus <> "Archived"
  375. archiveStatusFlag = 1
  376. End Select
  377. Case oldArchiveStatus = "Transferred outside GSK R&D" ' CHANGING FROM TRANSFERRED
  378. Select Case True
  379. Case newArchiveStatus = "Archived"
  380. archiveStatusFlag = 2
  381. Case newArchiveStatus <> "Archived"
  382. archiveStatusFlag = 1
  383. End Select
  384. Case oldArchiveStatus = "Destroyed" ' CHANGING FROM DESTROYED
  385. Select Case True
  386. Case newArchiveStatus = "Archived"
  387. archiveStatusFlag = 2
  388. Case newArchiveStatus <> "Archived"
  389. archiveStatusFlag = 1
  390. End Select
  391. Case oldArchiveStatus = "Delete from database" ' CHANGING FROM DELETE FROM DATABASE
  392. archiveStatusFlag = 1
  393. Case oldArchiveStatus = "Draft" ' CHANGING FROM DRAFT
  394. archiveStatusFlag = 1
  395. Case oldArchiveStatus = "Frozen" ' CHANGING FROM FROZEN
  396. archiveStatusFlag = 1
  397. Case oldArchiveStatus = "In Review" ' CHANGING FROM IN REVIEW
  398. archiveStatusFlag = 1
  399. Case oldArchiveStatus = "Rejected" ' CHANGING FROM REJECTED
  400. archiveStatusFlag = 1
  401. Case oldArchiveStatus = "DELETE" ' CHANGING FROM DELETE
  402. archiveStatusFlag = 1
  403. Case oldArchiveStatus = "DESTROYED(Dup)" ' CHANGING FROM DESTROYED(DUP)
  404. archiveStatusFlag = 1
  405. Case oldArchiveStatus = "MISSING(Dup)" ' CHANGING FROM MISSING(DUP)
  406. archiveStatusFlag = 1
  407. Case oldArchiveStatus = "TRANSFERRED(Dup)" ' CHANGING FROM TRANSFERRED(DUP)
  408. archiveStatusFlag = 1
  409. Case oldArchiveStatus = "WITHDRAWN(Dup)" ' CHANGING FROM WITHDRAWN(DUP)
  410. archiveStatusFlag = 1
  411. End Select
  412. End If
  413. Case Worksheets("Setup").archiveStatusButton1.Value = False ' CHANGE ARCHIVE STATUS
  414. If changeArchiveStatus.Value <> "" Then
  415. wsInput.Cells(rowNumber, archStatusCol).Value = changeArchiveStatus.Value
  416. wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
  417. updateFlag = 1
  418. End If
  419. archiveStatusFlag = 3
  420. End Select
  421. GoSub updateFlag
  422. Next rowNumber
  423. Select Case True ' APPLYING CHANGES TO ARCHIVE STATUS
  424. Case archiveStatusFlag = 0
  425. For rowNumber = 2 To LR
  426. wsInput.Cells(rowNumber, archStatusCol).Value = newArchiveStatus.Value
  427. wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
  428. updateFlag = 1
  429. GoSub updateFlag
  430. Next rowNumber
  431. Case archiveStatusFlag = 1
  432. MsgBox "Changing Archive Status from " & oldArchiveStatus.Value & " to " & newArchiveStatus.Value & " will result in record corruption", 16, "Requested Change Denied"
  433. Case archiveStatusFlag = 2
  434. answer = MsgBox("Do you have archivist permission to make this risky change to the Archive Status?", vbYesNo + vbQuestion, "Archive Status")
  435. If answer = vbYes Then
  436. For rowNumber = 2 To LR
  437. If wsInput.Cells(rowNumber, archStatusCol).Value = oldArchiveStatus.Value Then
  438. wsInput.Cells(rowNumber, archStatusCol).Value = newArchiveStatus.Value
  439. wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
  440. updateFlag = 1
  441. GoSub updateFlag
  442. End If
  443. Next rowNumber
  444. End If
  445. End Select
  446. GoTo progressTracker
  447. Exit Sub '****************************************************END OF MULTIEDIT SUB
  448. progressTracker:
  449. Dim sheetOwner(0 To 7) As String
  450. sheetOwner(0) = "Chrispy"
  451. sheetOwner(1) = "Darren"
  452. sheetOwner(2) = "Dunc"
  453. sheetOwner(3) = "Jayne"
  454. sheetOwner(4) = "Martin"
  455. sheetOwner(5) = "Max"
  456. sheetOwner(6) = "Sarah"
  457. sheetOwner(7) = "Sue"
  458. For i = 0 To 7
  459. Select Case True
  460. Case wsSetup.Range("K14").Value = sheetOwner(i)
  461. Set user = progWb.Worksheets("Progress").Range("B3:B10").Find(sheetOwner(i), LookAt:=xlWhole)
  462. Dim countRow As Integer
  463. wsToDoList.Activate
  464. countRow = Range("A:A").SpecialCells(xlCellTypeConstants).Count - 1 ' Accession List Count
  465. countDone = Range("B:B").SpecialCells(xlCellTypeConstants).Count - 1 ' Date Done List Count
  466. bigDate = Application.WorksheetFunction.max(wsToDoList.Range("B:B"))
  467. LRC = wsToDoList.Cells(Rows.Count, 2).End(xlUp).Row
  468. Dim projDate As Date
  469. With wsToDoList
  470. .Range("B2:B" & LRC).Copy Destination:=.Cells(1, 26)
  471. .Range("Z:Z").RemoveDuplicates Columns:=1, Header:=xlYes
  472. LRT = Cells(Rows.Count, 26).End(xlUp).Row
  473. .Range("F1").Value = LRT - 1
  474. .Columns(26).Delete
  475. End With
  476. If bigDate = "00:00:00" Then bigDate = Date
  477. If countDone = 0 Then countDone = 1
  478. If countRow = 0 Then countRow = 1
  479. projDate = Application.WorksheetFunction.WorkDay(bigDate, ((countRow - countDone) / (countDone / LRT)))
  480. progWb.Activate
  481. user.Offset(0, 2).Value = countRow
  482. user.Offset(0, 1).Value = countDone
  483. user.Offset(0, 4).NumberFormat = "dd/mm/yyyy"
  484. user.Offset(0, 4).Value = bigDate
  485. user.Offset(0, 5).Value = LRT - 1
  486. user.Offset(0, 6).Value = projDate
  487. Exit For
  488. End Select
  489. Next i
  490. progWb.Save
  491. progWb.Close
  492. Exit Sub
  493. updateFlag:
  494. If updateFlag Then
  495. Set updateCell = Cells(rowNumber, accessionCol)
  496. updateCell.Interior.Color = vbMagenta
  497. Set findVal = wsToDoList.Range("A2:A13676").Find(updateCell, LookAt:=xlWhole)
  498. If Not findVal Is Nothing Then
  499. findVal.Interior.Color = vbMagenta
  500. findVal.Offset(0, 1).Value = Date
  501. ElseIf findVal Is Nothing Then
  502. updateCell.Interior.Color = vbRed
  503. dodgyFlag = dodgyFlag + 1
  504. End If
  505. Set progWb = Workbooks("Metadata Update Progress Tracker.xlsx")
  506. Set findVal2 = progWb.Worksheets("Master QC").Range("A2:A1048576").Find(updateCell, LookAt:=xlWhole)
  507.  
  508. If Not findVal2 Is Nothing Then
  509. findVal2.Interior.Color = vbMagenta
  510. findVal2.Offset(0, 1).Value = Date
  511. findVal2.Offset(0, 2).Value = wsSetup.Range("K14").Value
  512. End If
  513.  
  514. End If
  515. updateFlag = 0
  516. Return
  517. Exit Sub
  518. noHeader:
  519. Call endNoUpdates
  520. Call ResetFind
  521. MsgBox "Titles missing: Please ensure grid is pasted into cell A1 and no column headers have been altered", 48, "Title Row Error"
  522. End
  523. carraigeReturnDetected:
  524. Call endNoUpdates
  525. Call ResetFind
  526. MsgBox "Carraige Return Detected on Row " & cellTest.Row & " - Please correct the error and try again", 48, "Carraige Return Detected"
  527. End
  528. End Sub
  529. Sub infoTypeGridMode() '****************************************************INFOTYPE GRID MODE
  530. Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
  531. Set wsSource = novaBook.Worksheets("Source")
  532. Set wsInput = novaBook.Worksheets("Input")
  533. Set wsSetup = novaBook.Worksheets("Setup")
  534. Set wsToDoList = novaBook.Worksheets("ToDoList")
  535. Set archiveStatusListRange = wsSource.Range("D2:D16")
  536. Set accessLevelListRange = wsSource.Range("E2:E17")
  537. Set changeArchiveStatus = wsSetup.Range("H22")
  538. Set oldArchiveStatus = wsSetup.Range("H25")
  539. Set newArchiveStatus = wsSetup.Range("I25")
  540. Set changeAccessLevel = wsSetup.Range("H29")
  541. Set oldAccessLevel = wsSetup.Range("H32")
  542. Set newAccessLevel = wsSetup.Range("I32")
  543. LR = wsInput.Cells(Rows.Count, 3).End(xlUp).Row ' DEFINE LAST ROW
  544. wsSetup.Activate
  545. Set storageRangeCells = wsInput.Range("C2:C" & LR)
  546. If ActiveSheet.Storage3.Value = True Then
  547. storageRangeCells.Value = "Recall UK"
  548. storageRangeCells.Interior.Color = vbGreen
  549. End If
  550. If ActiveSheet.Storage2.Value = True Then
  551. storageRangeCells.Value = "Stevenage"
  552. storageRangeCells.Interior.Color = vbGreen
  553. End If
  554. If ActiveSheet.Storage4.Value = True Then
  555. storageRangeCells.Value = ""
  556. storageRangeCells.Interior.Color = vbGreen
  557. End If
  558. End Sub
  559. Sub Clear()
  560. Worksheets("Input").Activate
  561. Cells.Clear
  562. Range("A1").Activate
  563. End Sub
  564. Sub startNoUpdates()
  565. With Application
  566. .ScreenUpdating = False
  567. .EnableEvents = False
  568. .Calculation = xlCalculationManual
  569. .DisplayAlerts = False
  570. End With
  571. End Sub
  572. Sub endNoUpdates()
  573. With Application
  574. .ScreenUpdating = True
  575. .EnableEvents = True
  576. .Calculation = xlCalculationAutomatic
  577. .DisplayAlerts = True
  578. End With
  579. End Sub
  580. Sub ResetFind()
  581. 'Sourced from [URL]http://stackoverflow.com/questions/243368/reset-excel-find-and-replace-dialog-box-parameters[/URL]
  582. Dim r As Range
  583. On Error Resume Next 'just in case there is no active cell
  584. Set r = ActiveCell
  585. On Error GoTo 0
  586. Cells.Find What:="", _
  587. After:=ActiveCell, _
  588. LookIn:=xlFormulas, _
  589. LookAt:=xlPart, _
  590. SearchOrder:=xlByRows, _
  591. SearchDirection:=xlNext, _
  592. MatchCase:=False, _
  593. SearchFormat:=False
  594. Cells.Replace What:="", Replacement:="", ReplaceFormat:=False
  595. If Not r Is Nothing Then r.Select
  596. Set r = Nothing
  597. End Sub
  598. Function SheetKiller(sheetToFind As String) As Boolean
  599. For Each Sheet In Worksheets
  600. If sheetToFind = Sheet.Name Then
  601. Application.DisplayAlerts = False
  602. Sheet.Delete
  603. Application.DisplayAlerts = True
  604. Exit Function
  605. End If
  606. Next Sheet
  607. End Function
  608. Sub next60()
  609. Dim rowSelect As Integer
  610. With Worksheets("ToDoList")
  611. .Activate
  612. rowSelect = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
  613. .Range(Cells(rowSelect, 1), Cells(rowSelect + 59, 1)).Activate
  614. .Range(Cells(rowSelect, 1), Cells(rowSelect + 59, 1)).Select
  615. End With
  616. Selection.Copy
  617. End Sub
  618. Sub next100()
  619. Dim rowSelect As Integer
  620. With Worksheets("ToDoList")
  621. .Activate
  622. rowSelect = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
  623. .Range(Cells(rowSelect, 1), Cells(rowSelect + 99, 1)).Activate
  624. .Range(Cells(rowSelect, 1), Cells(rowSelect + 99, 1)).Select
  625. End With
  626. Selection.Copy
  627. End Sub
  628.  
  629. Dim findVal, findVal2, storageRangeCells, user, rn, _
  630. archiveStatusListRange, accessLevelListRange, _
  631. changeArchiveStatus, oldArchiveStatus, newArchiveStatus, _
  632. changeAccessLevel, oldAccessLevel, newAccessLevel, _
  633. cellVal, toprow, containerRangeCells, cellTest, updateCell As Range
  634.  
  635. findVal is a Variant
  636. findVal2 is a Variant
  637. storageRangeCells is a Variant
  638. ...
  639. updateCell is a Range object
  640.  
  641. Dim findVal As Range
  642. Dim findVal2 As Range
  643. Dim storageRangeCells As Range
  644. ...
  645. Dim updateCell As Range
  646.  
  647. Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
  648. Set wsSource = novaBook.Worksheets("Source")
  649. Set wsInput = novaBook.Worksheets("Input")
  650. Set wsSetup = novaBook.Worksheets("Setup")
  651. Set wsToDoList = novaBook.Worksheets("ToDoList")
  652. Set archiveStatusListRange = wsSource.Range("D2:D16")
  653. Set accessLevelListRange = wsSource.Range("E2:E17")
  654. Set changeArchiveStatus = wsSetup.Range("H22")
  655. Set oldArchiveStatus = wsSetup.Range("H25")
  656. Set newArchiveStatus = wsSetup.Range("I25")
  657. Set changeAccessLevel = wsSetup.Range("H29")
  658. Set oldAccessLevel = wsSetup.Range("H32")
  659. Set newAccessLevel = wsSetup.Range("I32")
  660.  
  661. With changeArchiveStatus.Validation ' SET DATA VALIDATION FOR CHANGE ARCHIVE STATUS
  662. .Delete
  663. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  664. Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
  665. End With
  666.  
  667. Dim gridType As Boolean
  668. If novaBook.Sheets("Input").Range("B1") = "Title" Then
  669. gridType = 1
  670. LRBackUp = ... find last row
  671. If LRBackUp = 1 Then
  672. ...
  673. Else
  674. ...
  675. End If
  676. Else
  677. gridType = 0
  678. ...
  679. End If
  680.  
  681. Variable names: camel-case, starting with a lower case letter
  682. Subs and Functions: camel-case, starting with an upper case letter
  683. Constants: all upper case, words separated using underscores
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!