3
\$\begingroup\$

This is really the first big piece of code I've written for a work project, and there is a fair bit going on so I'm sure there is a lot of room for improvement.

I'd be interested specifically in speeding it up. I think the best way to do this would be to find a way of updating associated workbooks without having to open them, if that's even possible.

At the core it is simply replacing values based on inputs into text boxes or the state of toggle switches, but in order to determine metrics and such using the unique identifier for each row, I have had to run the code on a cell by cell, row by row basis.

I'm not sure what else to add here. I'm sure the code speaks for itself, but let me know if I need to add more info.

Public Declare Function sndPlaySound32 _
    Lib "winmm.dll" _
    Alias "sndPlaySoundA" ( _
        ByVal lpszSoundName As String, _
        ByVal uFlags As Long) As Long
Option Explicit
Dim findVal, findVal2, storageRangeCells, user, rn, _
archiveStatusListRange, accessLevelListRange, _
changeArchiveStatus, oldArchiveStatus, newArchiveStatus, _
changeAccessLevel, oldAccessLevel, newAccessLevel, _
cellVal, toprow, containerRangeCells, cellTest, updateCell As Range
Dim novaBook, WbkCheck, progWb, MyBook As Workbook
Dim wsSource, wsInput, wsSetup, wsToDoList, Sheet As Worksheet
Dim gridType, updateFlag, saveBackup As Boolean
Dim dodgyFlag, i, LRT, LRC, LR, LRBackup, countDone, _
accessionCol, TitleCol, archiveNotesCol, issueDateCol, _
retCatCol, storageSiteCol, authorCol, mudCol, rprdCol, _
rpsdeCol, rpsdCol, archLocCol, archStatusCol, accessLevel, _
dave, archiveStatusFlag, rowNumber, applicationCol As Byte
Dim answer As Variant
Dim filepaths As String
Dim bigDate As Date
Sub Macro()
Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
Set wsSource = novaBook.Worksheets("Source")
Set wsInput = novaBook.Worksheets("Input")
Set wsSetup = novaBook.Worksheets("Setup")
Set wsToDoList = novaBook.Worksheets("ToDoList")
Set archiveStatusListRange = wsSource.Range("D2:D16")
Set accessLevelListRange = wsSource.Range("E2:E17")
Set changeArchiveStatus = wsSetup.Range("H22")
Set oldArchiveStatus = wsSetup.Range("H25")
Set newArchiveStatus = wsSetup.Range("I25")
Set changeAccessLevel = wsSetup.Range("H29")
Set oldAccessLevel = wsSetup.Range("H32")
Set newAccessLevel = wsSetup.Range("I32")
If wsInput.Range("A1").Value = "" Then GoTo wrongPlace
Call startNoUpdates '******************************************************************* INITIAL SETUP STEPS
Workbooks.Open Filename:="R:\Novartis\Metadata Update Progress Tracker\Metadata Update Progress Tracker.xlsx"
Set progWb = Workbooks("Metadata Update Progress Tracker.xlsx")
gridType = 0
updateFlag = 0
archiveStatusFlag = 0
dodgyFlag = 0
wsSetup.Activate
wsSetup.Unprotect Password:="spectrum19"
With changeArchiveStatus.Validation                                                     ' SET DATA VALIDATION FOR CHANGE ARCHIVE STATUS
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
End With
With oldArchiveStatus.Validation                                                        ' SET DATA VALIDATION FOR OLD ARCHIVE STATUS
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
End With
With newArchiveStatus.Validation                                                        ' SET DATA VALIDATION FOR NEW ARCHIVE STATUS
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
End With
With changeAccessLevel.Validation                                                       ' SET DATA VALIDATION FOR CHANGE ACCESS LEVEL
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
End With
With oldAccessLevel.Validation                                                          ' SET DATA VALIDATION FOR OLD ACCESS LEVEL
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
End With
With newAccessLevel.Validation                                                          ' SET DATA VALIDATION FOR NEW ACCESS LEVEL
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
        Formula1:="='" & wsSource.Name & "'!" & accessLevelListRange.Address
End With
wsSetup.Protect Password:="spectrum19"
Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Input").Activate
LR = Cells(Rows.Count, 3).End(xlUp).Row                                                 ' DEFINE LAST ROW
If Range("B1").Value = "Title" Then gridType = 1                                        ' SET BOOLEAN FOR MULTIEDIT/INFOTYPE MODE
If Len(Dir("u:\Novartis Backup", vbDirectory)) = 0 Then MkDir "u:\Novartis Backup"
i = 1
saveBackup = False
Do While saveBackup = False                                                             ' MAKE BACKUP WORKBOOK
    filepaths = "u:\Novartis Backup\backup" & i & ".xlsx"
    If Dir(filepaths) = "" Then
        Set MyBook = Workbooks.Add
        With MyBook
            .Title = "backup"
            .SaveAs Filename:="u:\Novartis Backup\backup" & i & ".xlsx"
            .Sheets.Add.Name = "Multiedit_Backup"
            .Sheets.Add.Name = "Grid_Backup"
            Worksheets("Multiedit_Backup").Move Before:=ActiveWorkbook.Sheets(1)
        End With
        Workbooks("backup" & i & ".xlsx").Activate
        SheetKiller ("Sheet1")
        saveBackup = True
    Else: i = i + 1
    End If
 Loop
Set WbkCheck = ActiveWorkbook
Select Case True
    Case gridType = 1
        LRBackup = WbkCheck.Worksheets("Multiedit_Backup").Cells(Rows.Count, 1).End(xlUp).Row ' FIND LAST ROW ON NEW SHEET
        If LRBackup = 1 Then                                                                         ' ADD DATA TO Multiedit_Backup
            wsInput.Range("A1:AU" & LR).Copy Destination:=WbkCheck.Worksheets("Multiedit_Backup").Cells(LRBackup, 1)
        Else
            wsInput.Range("A1:AU" & LR).Copy Destination:=WbkCheck.Worksheets("Multiedit_Backup").Cells(LRBackup + 1, 1)
        End If
    Case gridType = 0
        LRBackup = WbkCheck.Worksheets("Grid_Backup").Cells(Rows.Count, 1).End(xlUp).Row  ' FIND LAST ROW ON NEW SHEET
        If LRBackup = 1 Then                                                                         ' ADD DATA TO Grid_Backup
            wsInput.Range("A1:G" & LR).Copy Destination:=WbkCheck.Worksheets("Grid_Backup").Cells(LRBackup, 1)
        Else
            wsInput.Range("A1:G" & LR).Copy Destination:=WbkCheck.Worksheets("Grid_Backup").Cells(LRBackup + 1, 1)
        End If
End Select
ActiveWorkbook.Save                                                                         ' SAVE & CLOSE BACKUP
ActiveWorkbook.Close
novaBook.Worksheets("Input").Activate
If gridType = 1 Then                                                                       ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
    Set containerRangeCells = Range("Z2:Z" & LR)
End If
If gridType = 0 Then                                                                       ' SET CONTAINER RANGE FOR INFOTYPE GRID MODE
    Set containerRangeCells = Range("D2:D" & LR)
End If
If Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Setup").ArchiveLocToggle1.Value = True Then      'UPDATE ARCHIVE LOCATION USING CONTAINER NUM AS REF
   For Each cellVal In containerRangeCells
        Set findVal = Worksheets("Source").Range("A1:B13676").Find(cellVal, LookAt:=xlWhole)
        If Not findVal Is Nothing Then
            cellVal.Offset(0, 1).Value = findVal.Offset(0, 1)
            cellVal.Offset(0, 1).Interior.ColorIndex = 4
            findVal.Interior.ColorIndex = xlNone
            findVal.Interior.Color = vbMagenta
            If gridType = 1 Then                                                                            ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
                cellVal.Offset(0, -26).Interior.ColorIndex = vbMagenta
            End If
        End If
    Next cellVal
    On Error GoTo 0
End If
If Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm").Worksheets("Setup").ContainerNumToggle2.Value = True Then ' UPDATE CONTAINER NUMBER FROM OLD TO NEW
   For Each cellVal In containerRangeCells
        Set findVal = Worksheets("Source").Range("A1:B13676").Find(cellVal, LookAt:=xlWhole)
        If Not findVal Is Nothing Then
            cellVal.Value = findVal.Offset(0, 1)
            cellVal.Interior.ColorIndex = 4
            findVal.Interior.ColorIndex = xlNone
            findVal.Interior.Color = vbMagenta
            If gridType = 1 Then                                                                              ' SET CONTAINER RANGE FOR MUTLIEDIT GRID MODE
                cellVal.Offset(0, -26).Interior.ColorIndex = vbMagenta
            End If
        End If
    Next cellVal
    On Error GoTo 0
End If
Set toprow = novaBook.Worksheets("Input").Range("1:1")
Select Case True
    Case gridType = 0
        Call infoTypeGridMode
    Case gridType = 1
        Call multieditGridMode
End Select
Call endNoUpdates
Call ResetFind
wsInput.Activate
If gridType = 1 Then                                                                                  ' COPY SHEET
    wsInput.Range("A2:AU" & LR).Select
Else
    wsInput.Range("A2:G" & LR).Select
End If
Selection.Copy
sndPlaySound32 "C:\Windows\Media\Cityscape\Windows Balloon.wav", 0&
Exit Sub '***************************************************************************************************END OF MAIN LINE
wrongPlace:
    Call endNoUpdates
    Call ResetFind
    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"
Exit Sub
End Sub
Sub multieditGridMode() '****************************************************MULTIEDIT GRID MODE
Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
Set wsSource = novaBook.Worksheets("Source")
Set wsInput = novaBook.Worksheets("Input")
Set wsSetup = novaBook.Worksheets("Setup")
Set wsToDoList = novaBook.Worksheets("ToDoList")
Set archiveStatusListRange = wsSource.Range("D2:D16")
Set accessLevelListRange = wsSource.Range("E2:E17")
Set changeArchiveStatus = wsSetup.Range("H22")
Set oldArchiveStatus = wsSetup.Range("H25")
Set newArchiveStatus = wsSetup.Range("I25")
Set changeAccessLevel = wsSetup.Range("H29")
Set oldAccessLevel = wsSetup.Range("H32")
Set newAccessLevel = wsSetup.Range("I32")
novaBook.Activate
wsInput.Activate
LR = Cells(Rows.Count, 3).End(xlUp).Row
For dave = 2 To LR                                                                  ' CHECK FOR CARRAIGE RETURNS
    Set cellTest = wsInput.Range("A" & dave)
    If Not IsNumeric(cellTest) Then
        GoTo carraigeReturnDetected
    End If
Next dave
Set toprow = novaBook.Worksheets("Input").Range("1:1")
On Error GoTo noHeader
accessionCol = toprow.Find("Accession Number", LookAt:=xlWhole).Column
TitleCol = toprow.Find("Title", LookAt:=xlWhole).Column
archiveNotesCol = toprow.Find("Archive Notes", LookAt:=xlWhole).Column
issueDateCol = toprow.Find("Issue Date", LookAt:=xlWhole).Column
retCatCol = toprow.Find("Record Retention Category", LookAt:=xlWhole).Column
storageSiteCol = toprow.Find("Storage Site", LookAt:=xlWhole).Column
authorCol = toprow.Find("Author", LookAt:=xlWhole).Column
mudCol = toprow.Find("Author ID ", LookAt:=xlWhole).Column
rpsdCol = toprow.Find("Retention Period Start Date", LookAt:=xlWhole).Column
rprdCol = toprow.Find("Retention Review Date", LookAt:=xlWhole).Column
rpsdeCol = toprow.Find("Retention Period Start Date Event", LookAt:=xlWhole).Column
archLocCol = toprow.Find("Archive Location", LookAt:=xlWhole).Column
archStatusCol = toprow.Find("Archive Status", LookAt:=xlWhole).Column
accessLevel = toprow.Find("Access Level", LookAt:=xlWhole).Column
applicationCol = toprow.Find("Application Name", LookAt:=xlWhole).Column

On Error GoTo 0
For rowNumber = 2 To LR
    If novaBook.Worksheets("Setup").TitleOption1.Value = True And Worksheets("Setup").TextBox1.Value <> "" Then ' AMEND TITLE
        wsInput.Cells(rowNumber, TitleCol).Value = Worksheets("Setup").TextBox1.Value & " - " & Cells(2, TitleCol).Value
        wsInput.Cells(rowNumber, TitleCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If novaBook.Worksheets("Setup").TitleOption2.Value = True And Worksheets("Setup").TextBox1.Value <> "" Then ' REPLACE TITLE
        wsInput.Cells(rowNumber, TitleCol).Value = Worksheets("Setup").TextBox1.Value
        wsInput.Cells(rowNumber, TitleCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If novaBook.Worksheets("Setup").NotesButton1.Value = True And Worksheets("Setup").TextBox7.Value <> "" Then ' AMEND ARCHIVE NOTES
        wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox7.Value & " - " & Cells(rowNumber, archiveNotesCol).Value
        wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If novaBook.Worksheets("Setup").NotesButton2.Value = True And Worksheets("Setup").TextBox7.Value <> "" Then ' REPLACE ARCHIVE NOTES
        wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox7.Value
        wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").Remove1.Value Then ' REMOVE ARCHIVE LOCATION
        wsInput.Cells(rowNumber, archLocCol).Clear
        wsInput.Cells(rowNumber, archLocCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If wsInput.Cells(LR, applicationCol).Value = "PD Shelf Life System" Then ' MOVE BAD APPLICATION NAME
        wsInput.Cells(LR, applicationCol).Value = ""
        wsInput.Cells(LR, applicationCol).Offset(0, -3).Value = "PD Shelf Life System"
        wsInput.Cells(LR, applicationCol).Interior.Color = vbMagenta
        wsInput.Cells(LR, applicationCol).Offset(0, -3).Interior.Color = vbMagenta
    End If
    If Worksheets("Setup").Remove2.Value Then ' REMOVE MUD ID
        wsInput.Cells(rowNumber, mudCol).Clear
        wsInput.Cells(rowNumber, mudCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox2.Text <> "" Then ' NEW AUTHOR
        wsInput.Cells(rowNumber, archiveNotesCol).Value = Worksheets("Setup").TextBox2.Text
        wsInput.Cells(rowNumber, archiveNotesCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox3.Text <> "" Then ' NEW MUD ID
        wsInput.Cells(rowNumber, mudCol).Value = Worksheets("Setup").TextBox3.Text
        wsInput.Cells(rowNumber, mudCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox4.Text <> "" Then ' NEW RPSD
        wsInput.Cells(rowNumber, rpsdCol).Value = Worksheets("Setup").TextBox4.Text
        wsInput.Cells(rowNumber, rpsdCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox5.Text <> "" Then ' NEW RPRD
        wsInput.Cells(rowNumber, rprdCol).Value = Worksheets("Setup").TextBox5.Text
        wsInput.Cells(rowNumber, rprdCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox6.Text <> "" Then ' NEW RPSDE
        wsInput.Cells(rowNumber, rpsdeCol).Value = Worksheets("Setup").TextBox6.Text
        wsInput.Cells(rowNumber, rpsdeCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").Range("newRetCatRng").Value <> "" Then ' NEW RETENTION CAT.
        wsInput.Cells(rowNumber, retCatCol).Value = Range("newRetCatRng").Value
        wsInput.Cells(rowNumber, retCatCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").TextBox8.Value <> "" Then ' NEW ISSUE DATE
        wsInput.Cells(rowNumber, issueDateCol).Value = Worksheets("Setup").TextBox8.Value
        wsInput.Cells(rowNumber, issueDateCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").Storage2.Value = True Then ' REPLACE STORAGE SITE WITH STEVENAGE
        wsInput.Cells(rowNumber, storageSiteCol).Value = "Stevenage"
        wsInput.Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").Storage3.Value = True Then ' REPLACE STORAGE SITE WITH RECALL UK
        Cells(rowNumber, storageSiteCol).Value = "Recall UK"
        Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    If Worksheets("Setup").Storage4.Value = True Then ' REPLACE STORAGE SITE WITH BLANK
        wsInput.Cells(rowNumber, storageSiteCol).Value = ""
        wsInput.Cells(rowNumber, storageSiteCol).Interior.Color = vbGreen
        updateFlag = 1
    End If
    Select Case True
        Case Worksheets("Setup").accessLevelButton1.Value = True ' FIND AND REPLACE ACCESS LEVEL
            If oldAccessLevel.Value <> "" = True And newAccessLevel.Value <> "" = True Then
                If Cells(rowNumber, accessLevel).Value = oldAccessLevel.Value Then
                    wsInput.Cells(rowNumber, accessLevel).Value = newAccessLevel.Value
                    wsInput.Cells(rowNumber, accessLevel).Interior.Color = vbGreen
                    updateFlag = 1
                End If
            End If
        Case Worksheets("Setup").accessLevelButton1.Value = False
                If changeAccessLevel.Value <> "" Then  ' CHANGE ACCESS LEVEL
                    wsInput.Cells(rowNumber, accessLevel).Value = changeAccessLevel.Value
                    wsInput.Cells(rowNumber, accessLevel).Interior.Color = vbGreen
                    updateFlag = 1
                End If
    End Select
    Select Case True                                                        ' ARCHIVE STATUS
        Case Worksheets("Setup").archiveStatusButton1.Value = True
            If oldArchiveStatus.Value <> "" = True And newArchiveStatus.Value <> "" = True Then ' FIND AND REPLACE ARCHIVE STATUS
                Select Case True
                    Case oldArchiveStatus = "Archived"                      ' CHANGING FROM ARCHIVED
                        Select Case True
                            Case newArchiveStatus = "Archived"
                                archiveStatusFlag = 0
                            Case newArchiveStatus = "Delete from database"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "Destroyed"
                                archiveStatusFlag = 2
                            Case newArchiveStatus = "Draft"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "Frozen"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "In Review"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "Missing"
                                archiveStatusFlag = 0
                            Case newArchiveStatus = "Rejected"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "Transferred outside GSK R&D"
                                archiveStatusFlag = 0
                            Case newArchiveStatus = "Withdrawn"
                                archiveStatusFlag = 0
                            Case newArchiveStatus = "DELETE"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "DESTROYED(Dup)"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "MISSING(Dup)"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "TRANSFERRED(Dup)"
                                archiveStatusFlag = 1
                            Case newArchiveStatus = "WITHDRAWN(Dup)"
                                archiveStatusFlag = 1
                        End Select
                    Case oldArchiveStatus = "Withdrawn"                     ' CHANGING FROM WITHDRAWN
                        Select Case True
                            Case newArchiveStatus = "Archived"
                                archiveStatusFlag = 2
                            Case newArchiveStatus <> "Archived"
                                archiveStatusFlag = 1
                        End Select
                    Case oldArchiveStatus = "Missing"                       ' CHANGING FROM MISSING
                        Select Case True
                            Case newArchiveStatus = "Archived"
                                archiveStatusFlag = 2
                            Case newArchiveStatus <> "Archived"
                                archiveStatusFlag = 1
                        End Select
                    Case oldArchiveStatus = "Transferred outside GSK R&D"   ' CHANGING FROM TRANSFERRED
                        Select Case True
                            Case newArchiveStatus = "Archived"
                                archiveStatusFlag = 2
                            Case newArchiveStatus <> "Archived"
                                archiveStatusFlag = 1
                        End Select
                    Case oldArchiveStatus = "Destroyed"                     ' CHANGING FROM DESTROYED
                        Select Case True
                            Case newArchiveStatus = "Archived"
                                archiveStatusFlag = 2
                            Case newArchiveStatus <> "Archived"
                                archiveStatusFlag = 1
                        End Select
                    Case oldArchiveStatus = "Delete from database"          ' CHANGING FROM DELETE FROM DATABASE
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "Draft"                         ' CHANGING FROM DRAFT
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "Frozen"                        ' CHANGING FROM FROZEN
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "In Review"                     ' CHANGING FROM IN REVIEW
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "Rejected"                      ' CHANGING FROM REJECTED
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "DELETE"                        ' CHANGING FROM DELETE
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "DESTROYED(Dup)"                ' CHANGING FROM DESTROYED(DUP)
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "MISSING(Dup)"                  ' CHANGING FROM MISSING(DUP)
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "TRANSFERRED(Dup)"              ' CHANGING FROM TRANSFERRED(DUP)
                        archiveStatusFlag = 1
                    Case oldArchiveStatus = "WITHDRAWN(Dup)"                ' CHANGING FROM WITHDRAWN(DUP)
                        archiveStatusFlag = 1
                End Select
            End If
        Case Worksheets("Setup").archiveStatusButton1.Value = False         ' CHANGE ARCHIVE STATUS
            If changeArchiveStatus.Value <> "" Then
                wsInput.Cells(rowNumber, archStatusCol).Value = changeArchiveStatus.Value
                wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
                updateFlag = 1
            End If
            archiveStatusFlag = 3
    End Select
    GoSub updateFlag
Next rowNumber
Select Case True ' APPLYING CHANGES TO ARCHIVE STATUS
    Case archiveStatusFlag = 0
        For rowNumber = 2 To LR
            wsInput.Cells(rowNumber, archStatusCol).Value = newArchiveStatus.Value
            wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
            updateFlag = 1
            GoSub updateFlag
        Next rowNumber
    Case archiveStatusFlag = 1
        MsgBox "Changing Archive Status from " & oldArchiveStatus.Value & " to " & newArchiveStatus.Value & " will result in record corruption", 16, "Requested Change Denied"
    Case archiveStatusFlag = 2
        answer = MsgBox("Do you have archivist permission to make this risky change to the Archive Status?", vbYesNo + vbQuestion, "Archive Status")
        If answer = vbYes Then
            For rowNumber = 2 To LR
                If wsInput.Cells(rowNumber, archStatusCol).Value = oldArchiveStatus.Value Then
                    wsInput.Cells(rowNumber, archStatusCol).Value = newArchiveStatus.Value
                    wsInput.Cells(rowNumber, archStatusCol).Interior.Color = vbGreen
                    updateFlag = 1
                    GoSub updateFlag
                End If
            Next rowNumber
        End If
End Select
GoTo progressTracker
Exit Sub '****************************************************END OF MULTIEDIT SUB
progressTracker:
    Dim sheetOwner(0 To 7) As String
    sheetOwner(0) = "Chrispy"
    sheetOwner(1) = "Darren"
    sheetOwner(2) = "Dunc"
    sheetOwner(3) = "Jayne"
    sheetOwner(4) = "Martin"
    sheetOwner(5) = "Max"
    sheetOwner(6) = "Sarah"
    sheetOwner(7) = "Sue"
    For i = 0 To 7
        Select Case True
            Case wsSetup.Range("K14").Value = sheetOwner(i)
                Set user = progWb.Worksheets("Progress").Range("B3:B10").Find(sheetOwner(i), LookAt:=xlWhole)
                Dim countRow As Integer
                wsToDoList.Activate
                countRow = Range("A:A").SpecialCells(xlCellTypeConstants).Count - 1 ' Accession List Count
                countDone = Range("B:B").SpecialCells(xlCellTypeConstants).Count - 1 ' Date Done List Count
                bigDate = Application.WorksheetFunction.max(wsToDoList.Range("B:B"))
                LRC = wsToDoList.Cells(Rows.Count, 2).End(xlUp).Row
                Dim projDate As Date
                With wsToDoList
                    .Range("B2:B" & LRC).Copy Destination:=.Cells(1, 26)
                    .Range("Z:Z").RemoveDuplicates Columns:=1, Header:=xlYes
                    LRT = Cells(Rows.Count, 26).End(xlUp).Row
                    .Range("F1").Value = LRT - 1
                    .Columns(26).Delete
                End With
                If bigDate = "00:00:00" Then bigDate = Date
                If countDone = 0 Then countDone = 1
                If countRow = 0 Then countRow = 1
                projDate = Application.WorksheetFunction.WorkDay(bigDate, ((countRow - countDone) / (countDone / LRT)))
                progWb.Activate
                user.Offset(0, 2).Value = countRow
                user.Offset(0, 1).Value = countDone
                user.Offset(0, 4).NumberFormat = "dd/mm/yyyy"
                user.Offset(0, 4).Value = bigDate
                user.Offset(0, 5).Value = LRT - 1
                user.Offset(0, 6).Value = projDate
                Exit For
            End Select
    Next i
    progWb.Save
    progWb.Close
Exit Sub
updateFlag:
    If updateFlag Then
        Set updateCell = Cells(rowNumber, accessionCol)
        updateCell.Interior.Color = vbMagenta
        Set findVal = wsToDoList.Range("A2:A13676").Find(updateCell, LookAt:=xlWhole)
        If Not findVal Is Nothing Then
            findVal.Interior.Color = vbMagenta
            findVal.Offset(0, 1).Value = Date
        ElseIf findVal Is Nothing Then
            updateCell.Interior.Color = vbRed
            dodgyFlag = dodgyFlag + 1
        End If
        Set progWb = Workbooks("Metadata Update Progress Tracker.xlsx")
        Set findVal2 = progWb.Worksheets("Master QC").Range("A2:A1048576").Find(updateCell, LookAt:=xlWhole)

            If Not findVal2 Is Nothing Then
                findVal2.Interior.Color = vbMagenta
                findVal2.Offset(0, 1).Value = Date
                findVal2.Offset(0, 2).Value = wsSetup.Range("K14").Value
            End If

    End If
    updateFlag = 0
Return
Exit Sub
noHeader:
Call endNoUpdates
Call ResetFind
MsgBox "Titles missing: Please ensure grid is pasted into cell A1 and no column headers have been altered", 48, "Title Row Error"
End
carraigeReturnDetected:
Call endNoUpdates
Call ResetFind
MsgBox "Carraige Return Detected on Row " & cellTest.Row & " - Please correct the error and try again", 48, "Carraige Return Detected"
End
End Sub
Sub infoTypeGridMode() '****************************************************INFOTYPE GRID MODE
Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
Set wsSource = novaBook.Worksheets("Source")
Set wsInput = novaBook.Worksheets("Input")
Set wsSetup = novaBook.Worksheets("Setup")
Set wsToDoList = novaBook.Worksheets("ToDoList")
Set archiveStatusListRange = wsSource.Range("D2:D16")
Set accessLevelListRange = wsSource.Range("E2:E17")
Set changeArchiveStatus = wsSetup.Range("H22")
Set oldArchiveStatus = wsSetup.Range("H25")
Set newArchiveStatus = wsSetup.Range("I25")
Set changeAccessLevel = wsSetup.Range("H29")
Set oldAccessLevel = wsSetup.Range("H32")
Set newAccessLevel = wsSetup.Range("I32")
LR = wsInput.Cells(Rows.Count, 3).End(xlUp).Row                                             ' DEFINE LAST ROW
wsSetup.Activate
        Set storageRangeCells = wsInput.Range("C2:C" & LR)
            If ActiveSheet.Storage3.Value = True Then
                storageRangeCells.Value = "Recall UK"
                storageRangeCells.Interior.Color = vbGreen
            End If
            If ActiveSheet.Storage2.Value = True Then
                storageRangeCells.Value = "Stevenage"
                storageRangeCells.Interior.Color = vbGreen
            End If
            If ActiveSheet.Storage4.Value = True Then
                storageRangeCells.Value = ""
                storageRangeCells.Interior.Color = vbGreen
            End If
End Sub
Sub Clear()
Worksheets("Input").Activate
Cells.Clear
Range("A1").Activate
End Sub
Sub startNoUpdates()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With
End Sub
Sub endNoUpdates()
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With
End Sub
Sub ResetFind()
     'Sourced from [URL]http://stackoverflow.com/questions/243368/reset-excel-find-and-replace-dialog-box-parameters[/URL]
    Dim r As Range
    On Error Resume Next 'just in case there is no active cell
    Set r = ActiveCell
    On Error GoTo 0
    Cells.Find What:="", _
    After:=ActiveCell, _
    LookIn:=xlFormulas, _
    LookAt:=xlPart, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False
    Cells.Replace What:="", Replacement:="", ReplaceFormat:=False
    If Not r Is Nothing Then r.Select
    Set r = Nothing
End Sub
Function SheetKiller(sheetToFind As String) As Boolean
    For Each Sheet In Worksheets
        If sheetToFind = Sheet.Name Then
            Application.DisplayAlerts = False
            Sheet.Delete
            Application.DisplayAlerts = True
            Exit Function
        End If
    Next Sheet
End Function
Sub next60()
Dim rowSelect As Integer
With Worksheets("ToDoList")
    .Activate
    rowSelect = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    .Range(Cells(rowSelect, 1), Cells(rowSelect + 59, 1)).Activate
    .Range(Cells(rowSelect, 1), Cells(rowSelect + 59, 1)).Select
End With
Selection.Copy
End Sub
Sub next100()
Dim rowSelect As Integer
With Worksheets("ToDoList")
    .Activate
    rowSelect = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    .Range(Cells(rowSelect, 1), Cells(rowSelect + 99, 1)).Activate
    .Range(Cells(rowSelect, 1), Cells(rowSelect + 99, 1)).Select
End With
Selection.Copy
End Sub
\$\endgroup\$
3
  • \$\begingroup\$ I'm not sure you'll be getting feedback specifically about speeding it up, for there are a lot of things for reviewers to point out. The use of Select and Activate alone is a performance issue, but I don't see anyone addressing it without first addressing the readability and maintainability of the code. Buckle up, you're in for a ride! \$\endgroup\$ Nov 2 '17 at 11:48
  • \$\begingroup\$ @Mat'sMug lol I was going to suggest running it through Rubberduck as a first step... Also, HotSauceCoconuts perhaps remove stuff that identifies your company \$\endgroup\$ Nov 2 '17 at 11:50
  • \$\begingroup\$ Indeed, Rubberduck can help here (disclaimer: I own that website and manage the open-source VBIDE add-in project it's for)... Too bad the Extract Method refactoring isn't ready yet. \$\endgroup\$ Nov 2 '17 at 11:55
1
\$\begingroup\$

@MatsMug is right, there is a lot going on here. I won't be able to address everything but I'll at least give you a starting point.

Glad you're using Option Explicit.

That's usually the first thing I look for in a code set. Finding it means that I can be assured that each variable has a definition at least somewhere.

Global variable declarations are not declared as you think they are

Just taking one line of the declaration:

Dim findVal, findVal2, storageRangeCells, user, rn, _
    archiveStatusListRange, accessLevelListRange, _
    changeArchiveStatus, oldArchiveStatus, newArchiveStatus, _
    changeAccessLevel, oldAccessLevel, newAccessLevel, _
    cellVal, toprow, containerRangeCells, cellTest, updateCell As Range

I can tell you that if your intention is that ALL of those variables be declared as a Range type, I'm sorry to inform you that they're not. In VBA, each variable Dim must be matched with an As <type>. If it's not, then each variable defaults to Variant. So in your case:

findVal is a Variant
findVal2 is a Variant
storageRangeCells is a Variant
...
updateCell is a Range object

If order to make this work, you really do have to go variable by variable:

Dim findVal As Range
Dim findVal2 As Range
Dim storageRangeCells As Range
...
Dim updateCell As Range

(As a side note, anytime I see myself requiring a large number of module-global variables, that's an indication that my design is inefficient and should be reworked.)

Unnecessary repetitive code

In several of your Subs, you are unnecessarily repeating a block of code:

Set novaBook = Workbooks("Chrispy - Novartis Super Grid Updater Macro.xlsm")
Set wsSource = novaBook.Worksheets("Source")
Set wsInput = novaBook.Worksheets("Input")
Set wsSetup = novaBook.Worksheets("Setup")
Set wsToDoList = novaBook.Worksheets("ToDoList")
Set archiveStatusListRange = wsSource.Range("D2:D16")
Set accessLevelListRange = wsSource.Range("E2:E17")
Set changeArchiveStatus = wsSetup.Range("H22")
Set oldArchiveStatus = wsSetup.Range("H25")
Set newArchiveStatus = wsSetup.Range("I25")
Set changeAccessLevel = wsSetup.Range("H29")
Set oldAccessLevel = wsSetup.Range("H32")
Set newAccessLevel = wsSetup.Range("I32")

Especially since those variables are global, this makes no sense. Set them once at the beginning and forget it (unless they change, and it doesn't look like they do).

Validation changes

At the beginning of your macro, there is a section to change the data validation status of a few cells.

With changeArchiveStatus.Validation          ' SET DATA VALIDATION FOR CHANGE ARCHIVE STATUS
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
         Formula1:="='" & wsSource.Name & "'!" & archiveStatusListRange.Address
End With

Data validation is typical when the user is entering data manually. Though you're changing some of these values (cells) within your macro, it's easy to guarantee the value that is assigned. For that reason, the data validation in this case is not at all necessary. If it's needed after the macro runs, then apply these validation criteria at the end.

Avoid using Select or Activate

Since I can't refer you to the (now deprecated) StackOverflow Documention section where there's a clear explanation, please look at these links for a good read:

  1. How to avoid using Select in Excel VBA
  2. How to Avoid the Select Method in VBA & Why
  3. Power Excel vba secret, avoid using select

Declare a variable, then set it, then use it as close together as possible

A good example of this is your gridType variable. It's defined as a global (so I had to go search for the definition to see what type it is). It's defaulted to a value at the top of the macro (gridType = 0) with no explanation as to why. Many lines farther down it's conditionally set to 1 (side note: if you avoid using Activate on the worksheet, then it's easier to see where the Range("B1") is coming from). Finally, gridType is used in a Select Case statement. --- Oh, and by the way gridType should be a Boolean and you're assigning an integer to it!

It would be clearer and more concise to develop your code this way:

Dim gridType As Boolean
If novaBook.Sheets("Input").Range("B1") = "Title" Then
    gridType = 1
    LRBackUp = ... find last row
    If LRBackUp = 1 Then
        ...
    Else
        ...
    End If
Else
    gridType = 0
    ...
End If

As you can see, I didn't even need the Select statement here. This is just one way you can reduce your code for efficiency and speed.

Consistency in variable naming

There have been holy wars fought and blood spilled over naming conventions. The important point is to pick a style and be consistent. I'll give you some guidance for my own style as a reference, but please consider what your own conventions should be and go with that.

Variable names:  camel-case, starting with a lower case letter
Subs and Functions: camel-case, starting with an upper case letter
Constants: all upper case, words separated using underscores

There can easily be much more written on this topic. As a starting point, read this article for some ideas (it's for .NET, but the discussion is valid for most any language).

There is lots more that can be said about your code, and this is only a start. But if you can address some of these issues you'll not only get faster code, but it will be better organized. We'll all be happy to review and comment on your next version

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.