Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'####################################################################################################################
'                                               Chem Dev Compass Code
'####################################################################################################################
'
'   This tool is allow the department to standardise the way in which we can:
'       *Find guidance in the form of SOPs/Sharepoints/ANGEL Docs
'       *Plan project actvities
'       *Record FTE in the standard RBU format
'       *Report to the Leadership team across projects
'       *Knowlegde management for key documents
'
'   Upon opening this document, new users are asked if erorrs are documented using their emails, these details are
'   then saved in a table on sheet12("Users"). It then compares the mastercode document stored in sharepoint for
'   any updates (based on the last modified date and the date stored on the sheet10("SuperUsers")), to do this
'   the chem dev sharepoint is mapped to a free drive, and then the drive is searched for the mastercode document.
'   If a newer version is live then, the file is temp file is copied to the users desktop, and all code is removed
'   from the users Chem Dev Compass file, and then the new code is copied across.
'
'
'   Key sharepoint lists linked to this document are:
'       * Activities in Plan - https://azcollaboration.sharepoint.com/sites/MS259/MD/CS/Lists/NavAid_Activities/AllItems.aspx
'       * WorkPackages in Activities - https://azcollaboration.sharepoint.com/sites/MS259/MD/CS/Lists/NavAid_WorkPackages/AllItems.aspx
'       * Critical Question asked in Transition - https://azcollaboration.sharepoint.com/sites/MS259/MD/CS/Lists/NavAid_CriticalQuestion/AllItems.aspx
'       * DS Manufacture activities - https://azcollaboration.sharepoint.com/sites/MS259/MD/CS/Lists/NavAid_CampaignActs/AllItems.aspx
'
'####################################################################################################################
'                                           Written by: Alex Lamacraft
'                                            Last Updated: 22/09/2020
'####################################################################################################################
'
'

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    
    Dim filedatetime2 As Date
    Dim CurrentCompass As Workbook
    Dim CurrentCompass_Main As Worksheet
    Dim mapped As Boolean
    Dim DriveName As String
    
Sub autoupdateButton()
    ThisWorkbook.AutoUpdate
End Sub
Private Sub Workbook_Open()
'####################################################################################################################
'               Gets permission from user to use their email to contact the team if they have a error.
'                  Details are then saved in table on sheet12("Users"). Then runs autoupdate script
'####################################################################################################################
x = 0
        Set CurrentCompass = ThisWorkbook
        Set CurrentCompass_Main = CurrentCompass.Sheets(Sheet69.Name)
On Error Resume Next
 x = Sheet12.ListObjects(1).DataBodyRange.Find(Environ("Username"), lookat:=xlWhole, LookIn:=xlValues)
On Error GoTo 0


If x = 0 Then

    ans = MsgBox("This tool has the ability to send error reports, this will send an email from your account if the tool encounters a error." & Chr(13) & "To enable this feature please click Yes.", vbYesNo + vbInformation, "Automatic Error Emails")
    rw = Sheet12.ListObjects(1).ListRows.Count + 2
        
    If ans = vbYes Then
        Sheet12.Cells(rw, 1).Value = Environ("Username")
        Sheet12.Cells(rw, 2).Value = True
        Sheet12.Cells(rw, 3).Value = Application.UserName
      
    Else
        Sheet12.Cells(rw, 1).Value = Environ("Username")
        Sheet12.Cells(rw, 2).Value = False
        Sheet12.Cells(rw, 3).Value = Application.UserName
      
    End If
  
End If


Date_Check

End Sub
Private Sub DownLoadFile(MasterCodePath, TempFileName)
'####################################################################################################################
'                   Copies MasterCode File from Drive to users desktop and names using temp name
'####################################################################################################################

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    strSavePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & TempFileName
    
    If objFSO.FileExists(MasterCodePath) Then
        objFSO.CopyFile MasterCodePath, strSavePath
    End If


End Sub
Sub reOpenCode()
'####################################################################################################################
'                                           Welcome message after a failed update
'####################################################################################################################

MsgBox "This file has been reset, as the autoupdate has failed. If this continues contact a SuperUser, in the feedback tab", vbCritical + vbOKOnly, "Autoupdate Failed"
Application.DisplayAlerts = True
With Sheet69.Cells(3, 2)
    .Value = "Update available: 1"
    .Interior.Color = RGB(255, 199, 206)
    .Font.Color = RGB(156, 0, 6)
    .Font.Bold = True
End With

End Sub
Sub CloseAndReopen()
'####################################################################################################################
'                                           Closes and reopens the file
'####################################################################################################################
Dim wb As Excel.Workbook
Set wb = ThisWorkbook

Dim pth As String
pth = wb.FullName
Application.DisplayAlerts = False


Application.OnTime (Now + TimeValue("00:00:01")), "ThisWorkbook.reOpenCode"
wb.Close (False)



End Sub
Sub Date_Check()
'####################################################################################################################
'
'                   script which calls routines to check if the file is out of date
'
'####################################################################################################################
    mapped = False
    
    On Error GoTo ErHandler1
        MapSharePointToDrive
        mapped = True
        FindMasterCodePath MasterCodePath, FileAutoUpdate
        MasterCodeFileDate = filedatetime2
        
        If Not IsEmpty(MasterCodeFileDate) Then
            
            lastUpdate = Split(Sheet69.Cells(3, 2).Value, ":")(1)
            Application.EnableEvents = False
            
            If CDate(lastUpdate) >= MasterCodeFileDate Then
                With Sheet69.Cells(3, 2)
                    .Value = "Version: " & MasterCodeFileDate
                    .Interior.Color = RGB(198, 239, 206)
                    .Font.Color = RGB(0, 97, 0)
                    .Font.Bold = True
                End With
                Sheet69.Shapes("Button 11").Visible = False
                
            Else
                With Sheet69.Cells(3, 2)
                    .Value = "Update available: " & Split(Sheet69.Cells(3, 2).Value, ": ")(1)
                    .Interior.Color = RGB(255, 199, 206)
                    .Font.Color = RGB(156, 0, 6)
                    .Font.Bold = True
                End With
                Sheet69.Shapes("Button 11").Visible = True
                
            
            End If
            
            Application.EnableEvents = False
            
        
        Else
            MsgBox "Autoupdate stopped. Unable to establish a connection with the mastercode file." & Chr(13) & "This Compass is still okay to use, although we would recommend updating it as soon as possible.", vbInformation + vbOKOnly, "Autoupdate Failed"
        End If
                
        'UnMapSharePointDrive
          UnMapSharePointToDrive
        
        
    Exit Sub
ErHandler1:
        'UnMapSharePointDrive
        If mapped Then UnMapSharePointToDrive
        MsgBox "Autoupdate stopped. Unable to establish a connection with the mastercode file." & Chr(13) & "This Compass is still okay to use, although we would recommend updating it as soon as possible.", vbCritical + vbOKOnly, "Autoupdate Failed"
      


End Sub
Sub AutoUpdate()
'####################################################################################################################
'               script which calls routines to run the update, these codes cannot be updated
'                                           and must stay in this module
'
'       on starting the update the file is saved, and then if a error is met, the file is closed without saving,
'       protecting the file from any issues down the line. A message informs the users to contact SuperUsers.
'
'####################################################################################################################
    
    Dim Saved As Boolean
    Dim FileAutUpdate As Boolean
    Dim MasterCodePath As String
    Dim MasterCodeFileDate As Date
    Dim MainPageName As String
    Dim ThisFileName As String
    Dim thisFilePath As String
    Dim tmpCompass As Workbook
    
    Set CurrentCompass = ThisWorkbook
    Set CurrentCompass_Main = CurrentCompass.Sheets(Sheet69.Name)
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    mapped = False
    Saved = False
    
    On Error GoTo ErHandler1
        FileAutoUpdate = False
        MapSharePointToDrive

        FindMasterCodePath MasterCodePath, FileAutoUpdate
        MasterCodeFileDate = Int(CDate(filedatetime2))
        MainPageName = Sheet69.Name
         ThisFileName = ThisWorkbook.Name
         thisFilePath = ThisWorkbook.Path

        If FileAutoUpdate Then
            ans = MsgBox("There is an update available would you like to update this tool?", vbYesNo, "Compass Update")
            If ans = vbYes Then
                
                Application.EnableEvents = False
                
                

                CurrentCompass.Save
                Saved = True
                
                TempFileName = "Compass_Temp_" & Replace(Date, "/", "-") & ".xlsm"
                
                DownLoadFile MasterCodePath, TempFileName
                
                DeleteOldModules
                
                AddNewModules TempFileName, ThisFileName
                TrasferNewSheetsAndControls TempFileName, ThisFileName
                Application.EnableEvents = True
                Application.Wait (Now + TimeValue("0:00:03"))
                MsgBox "New code transfer successful", vbInformation + vbOKOnly, "AutoUpdate"
                DeleteTempFile TempFileName
                MsgBox "Temp file deleted", vbInformation + vbOKOnly, "AutoUpdate"
                

                CurrentCompass.Save
                
                
                MsgBox "Compass updated", vbOKOnly, "Compass Update"
               
            Else
                MsgBox "Compass not updated", vbOKOnly, "Compass Update"
                
                With Workbooks(ThisFileName).Sheets(MainPageName).Cells(3, 2)
                    .Value = "Update available: " & MasterCodeFileDate
                    .Interior.Color = RGB(255, 199, 206)
                    .Font.Color = RGB(156, 0, 6)
                    .Font.Bold = True
                End With
                Sheet69.Shapes("Button 11").Visible = True
            End If
            
        ElseIf FileAutoUpdate <> 0 Then
            MsgBox "Autoupdate stopped. Unable to establish a connection with the mastercode file." & Chr(13) & "This Compass is still okay to use, although we would recommend updating it as soon as possible.", vbInformation + vbOKOnly, "Autoupdate Failed"
        End If
        
            
        
        
        Application.ScreenUpdating = True
        Application.Cursor = xlDefault
        CurrentCompass_Main.Activate
        CurrentCompass_Main.Cells(1, 1).Select
         Application.Wait (Now + TimeValue("0:00:03"))
        'UnMapSharePointDrive
        UnMapSharePointToDrive
        'updates update text
       ' If ans = vbYes Then CurrentCompass_Main.Cells(3, 2).Value = "Version: " & Int(CDate(filedatetime2)) + 1
        Exit Sub
        
ErHandler1:
    On Error Resume Next
        Application.ScreenUpdating = True
        Application.Cursor = xlDefault
    
        If DriveName <> "" And mapped Then UnMapSharePointToDrive
        If TempFileName <> "" Then DeleteTempFile TempFileName
        If ans = vbYes And Saved = True Then
            CloseAndReopen
        ElseIf ans = vbYes And Saved = False Then
            MsgBox "Failed to save the file. Have you checked it out?", vbCritical + vbOKOnly, "Autoupdate Failed"
        Else
             MsgBox "Autoupdate stopped. Unable to establish a connection with the mastercode file." & Chr(13) & "This Compass is still okay to use, although we would recommend updating it as soon as possible.", vbCritical + vbOKOnly, "Autoupdate Failed"
        End If

End Sub
Private Sub UnMapSharePointToDrive()
     CreateObject("WScript.Network").RemoveNetworkDrive DriveName
     mapped = False
End Sub
Private Sub updateValues()
                With c
                    .Interior.Color = RGB(198, 239, 206)
                    .Font.Color = RGB(0, 97, 0)
                    .Font.Bold = True
                End With
            CurrentCompass_Main.Shapes("Button 11").Visible = False
End Sub
Private Sub SearchAllFilesFolders(ObjSubFolder As Object, objFile As Object, DriveName)
'####################################################################################################################
'                       Loops through all file and folder in drive to find the MasterCode File
'####################################################################################################################
    Dim objFolder As Object
    'Dim objFile As Object

    For Each objFile In ObjSubFolder.Files
        If objFile.Type = "Microsoft Excel Macro-Enabled Worksheet" And objFile.Name = "ChemDevCompassCode.xlsm" Then
            Exit Sub
        End If
        
    Next
    For Each objFolder In ObjSubFolder.subfolders
        If Left(objFolder.Path, 13) = DriveName & "\CD Compass" Then
            SearchAllFilesFolders objFolder, objFile, DriveName
            
        End If
    Next


End Sub
Private Sub FindMasterCodePath(MasterCodePath, FileAutoUpdate)
'####################################################################################################################
'           Compares the known path of the file, to see if is there, otherwise it searchs the whole sharepoint
'####################################################################################################################
    
    Dim objFolder As Object
    Dim objNet As Object
    Dim objFile As Object
    Dim FS As Object
    Dim StartTime As Date
    Dim EndTime As Date
    
    fileModTime = 0
    StartTime = Time()
    EndTime = DateAdd("n", 1, Time())
    counter = 1
    On Error Resume Next
    Do While (fileModTime = 0)
        Application.StatusBar = "Trying to access SharePoint... Attempt: " & counter
        fileModTime = FileDateTime(DriveName & "\CD Compass\CompassCode\ChemDevCompassCode.xlsm")
        filedatetime2 = FileDateTime(DriveName & "\CD Compass\CompassCode\ChemDevCompassCode.xlsm")
        If (Time() >= EndTime) Then Exit Do
        If fileModTime = 0 Then Application.Wait (Now + TimeValue("0:00:10"))
        counter = counter + 1
    Loop
        Application.StatusBar = False
    On Error GoTo 0
    
    
    If fileModTime = 0 Then
        Set FS = CreateObject("Scripting.FileSystemObject")
        Set objFolder = FS.getfolder(DriveName)
        
        SearchAllFilesFolders objFolder, objFile, DriveName
        
        If objFile.Type = "Microsoft Excel Macro-Enabled Worksheet" And objFile.Name = "ChemDevCompassCode.xlsm" Then
            fileModTime = FileDateTime(objFile.Path)
        End If
        MasterCodePath = objFile.Path
    Else
        
        MasterCodePath = DriveName & "\CD Compass\CompassCode\ChemDevCompassCode.xlsm"
    End If

    If fileModTime >= CDate(Split(Sheet69.Cells(3, 2).Value, ":")(1)) Then
        
        FileAutoUpdate = True
        
        
    ElseIf fileModTime = 0 Then
        FileAutoUpdate = False
        MsgBox "You have been unable to find the file on SharePoint." & Chr(13) & "The Compass has not been updated.", vbCritical + vbOKOnly, "Connection Failed"
    
    End If
    
    
    

End Sub
Private Sub MapSharePointToDrive()
'####################################################################################################################
'                               Maps the chem dev sharepoint to the users free drive
'####################################################################################################################

    Dim objFolder As Object
    Dim objNet As Object
    Dim objFile As Object
    Dim FS As Object

    SharepointAddress = "https://azcollaboration.sharepoint.com/sites/MS259/MD/CS/Improvement_Projects/"
 
    FindFreeDrive
    
    Set objNet = CreateObject("WScript.Network")
    Set FS = CreateObject("Scripting.FileSystemObject")
    objNet.MapNetworkDrive DriveName, SharepointAddress
    mapped = True

End Sub

Private Sub FindFreeDrive()
'####################################################################################################################
'                   Loops through all the drives on users laptop and find the first free one
'####################################################################################################################


    Set objNet = CreateObject("WScript.Network")
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set dc = FS.Drives
    DriveName = ""
    For ascii = 65 To 90
        drivefree = 0
        For Each drive In dc
            If (Chr(ascii)) = Left(drive, 1) Then
                drivefree = 1
                Exit For
            End If
        Next
        If drivefree = 0 Then
            DriveName = (Chr(ascii)) & ":"
            Exit For
        End If
    Next

End Sub
Sub tmpFile(TempFileName, strURL)

strSavePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & Fname
DownloadFileFromWeb = URLDownloadToFile(0, strURL, strSavePath, 0, 0)



End Sub
Private Sub DeleteTempFile(TempFileName)

On Error Resume Next
    Workbooks(TempFileName).Close savechanges:=False
    Kill CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & TempFileName
On Error GoTo 0

End Sub
Private Sub DeleteOldModules()
'####################################################################################################################
'       Deletes all scrips in current workbook this is everything that is not held in a worksheet (type 100)
'####################################################################################################################

    For Each Component In ActiveWorkbook.VBProject.VBComponents
        If Component.Type <> 100 Then
            With ActiveWorkbook.VBProject.VBComponents
                .Remove .Item(Component.Name)
            End With
        End If
    Next
    
End Sub
Private Sub AddNewModules(TempFileName, ThisFileName)
'####################################################################################################################
'       Copys all new scrips to current workbook this is everything that is not held in a worksheet (type 100)
'####################################################################################################################
    
    Application.EnableEvents = False
    Workbooks.Open CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & TempFileName, False, False
    Application.EnableEvents = True

    Application.ScreenUpdating = False
    
    For Each Component In Workbooks(TempFileName).VBProject.VBComponents
        If Component.Type <> 100 Then

            Component.Export "C:\temp\" & Component.Name & ".bas"
            Workbooks(ThisFileName).VBProject.VBComponents.Import "C:\temp\" & Component.Name & ".bas"
            Kill "C:\temp\" & Component.Name & ".bas"
            
        End If
    Next


End Sub
Private Sub updateListObject(wSheet, CurrentCompass, NewCompass)
'####################################################################################################################
'                               updates tabels sizes, and transfers any formulas
'####################################################################################################################
    
    listObjectName = ""
    
    On Error Resume Next
        listObjectName = CurrentCompass.Sheets(wSheet.Name).ListObjects(1).Name
    On Error GoTo 0
    
    If listObjectName <> "" Then
        Set newListObject = wSheet.ListObjects(1)
        Set oldListObject = CurrentCompass.Sheets(wSheet.Name).ListObjects(1)
        
        If newListObject.ListColumns.Count < oldListObject.ListColumns.Count Then
            
            oldColumnNumber = Range(Split(oldListObject.Range.Address, "$")(3) & "1").Column
            newColumnNumber = Range(Split(newListObject.Range.Address, "$")(3) & "1").Column
            
            RowCount = Split(oldListObject.Range.Address, "$")(4)
            newRange = Range(oldListObject.Range.Address).Resize(RowCount, newColumnNumber).Address
            
            oldListObject.Resize Range(newRange)
            
            For Column = oldColumnNumber To newColumnNumber
                wSheet.Cells(2, 1).Value = 1
                CurrentCompass.Sheets(wSheet.Name).Cells(2, 1).Value = 1
                
                CurrentCompass.Sheets(wSheet.Name).Cells(1, Col).Value = WS.Cells(1, Col).Value
                
                oldListObject.ListColumns(wSheet.Cells(1, Col).Value).DataBodyRange.FormulaR1C1 = newListObject.ListColumns(wSheet.Cells(1, Col).Value).DataBodyRange.FormulaR1C1
                
            Next
        End If
        CurrentCompass.Sheets(wSheet.Name).Visible = NewCompass.Sheets(wSheet.Name).Visible
    End If
    
   
    
End Sub
Private Sub updateCustomSheet(wSheet, CurrentCompass, NewCompass, absRefference)
'####################################################################################################################
'               Can't delete sheet as formulas will not work, hence replacing each line accourdingly.
'
'       Copies entire sheet to current Compass, and then removes referneces to Mastercode file, then removes all
'               the code in assoicated with the sheet and reads each line of the new code into the file
'####################################################################################################################

    For Each activeWSheet In CurrentCompass.Sheets
    
        If activeWSheet.CodeName = wSheet.CodeName Then
        
            activeWSheet.Visible = xlSheetVisible
            wSheet.Visible = xlSheetVisible
            activeWSheet.Unprotect Password:="Password"
            
                Application.EnableEvents = False
                    wSheet.UsedRange.Copy
                    activeWSheet.Range("A1").PasteSpecial
                    activeWSheet.Cells.Replace what:=absRefference, replacement:="", lookat:=xlPart, MatchCase:=False
                Application.EnableEvents = True
                
            activeWSheet.Protect Password:="Password", _
                DrawingObjects:=False, _
                Contents:=False, _
                Scenarios:=True, _
                UserInterfaceOnly:=False, _
                AllowFormattingCells:=True, _
                AllowFormattingColumns:=True, _
                AllowFormattingRows:=True, _
                AllowInsertingColumns:=False, _
                AllowInsertingRows:=False, _
                AllowInsertingHyperlinks:=True, _
                AllowDeletingColumns:=False, _
                AllowDeletingRows:=False, _
                AllowSorting:=True, _
                AllowFiltering:=True, _
                AllowUsingPivotTables:=False
                
            
            
            activeWSheet.Visible = xlSheetHidden
            wSheet.Visible = xlSheetHidden
            
            
            Set newSheetCode = NewCompass.VBProject.VBComponents(wSheet.CodeName).CodeModule
            Set oldSheetCode = CurrentCompass.VBProject.VBComponents(activeWSheet.CodeName).CodeModule
            
            oldSheetCode.deletelines 1, oldSheetCode.CountOfLines
            
            
            For Line = 1 To newSheetCode.CountOfLines
            
                oldSheetCode.insertlines Line, newSheetCode.Lines(Line, 1)
            
            Next
            Set newSheetCode = Nothing
            Set oldSheetCode = Nothing
            Exit For
        
        End If
    
    Next



End Sub
Private Sub TransferSheetControls(wSheet, CurrentCompass, NewCompass)
'####################################################################################################################
'
'                       Compares controllers on the sheet and adds new ones then replaces code
'
'####################################################################################################################

        For Each newButton In wSheet.Shapes
            buttonFound = False
            
            For Each oldButton In CurrentCompass.Sheets(wSheet.Name).Shapes
            
                If oldButton.Name = newButton.Name Then
                    buttonFound = True
                    Exit For
                End If

            Next
            
            If Not (buttonFound) Then
            
                newButton.Copy
                CurrentCompass.Sheets(wSheet.Name).Paste
                With CurrentCompass.Sheets(wSheet.Name).Buttons(CurrentCompass.Sheets(wSheet.Name).Buttons.Count)
                
                    .Name = newButton.Name
                    .Top = newButton.Top
                    .Left = newButton.Left
                    .OnAction = CurrentCompass.Name & "!" & Split(.OnAction, "!")(1)
                    
                End With
                
            End If
        Next
        
        Set newSheetCode = NewCompass.VBProject.VBComponents(wSheet.CodeName).CodeModule
        Set oldSheetCode = CurrentCompass.VBProject.VBComponents(wSheet.CodeName).CodeModule
        
        oldSheetCode.deletelines 1, oldSheetCode.CountOfLines
        
        
        For Line = 1 To newSheetCode.CountOfLines
        
            oldSheetCode.insertlines Line, newSheetCode.Lines(Line, 1)
       
        Next
        Set newSheetCode = Nothing
        Set oldSheetCode = Nothing

End Sub
Private Sub TrasferNewSheetsAndControls(TempFileName, ThisFileName)
'####################################################################################################################
'               Goes through each sheet in the documents and transfer controls and shapes as required
'                      First Determains if sheet is a datatable, if so then resize according
'                      Second test if there are any new controls to be transfered
'                      Third check if there is any new sheets to be copied
'                      Fourth Replace WorkPack Sheet and DS Manufacture sheets
'####################################################################################################################
    Set CurrentCompass = Workbooks(ThisFileName)
    Set NewCompass = Workbooks(TempFileName)
    
    absRefference = "'" & TempFileName & "'!"
    Application.ScreenUpdating = False
    For Each wSheet In NewCompass.Sheets
    
        
        updateListObject wSheet, CurrentCompass, NewCompass
        
        If wSheet.CodeName = "Sheet69" Or wSheet.CodeName = "Sheet10" Or wSheet.CodeName = "Plan" Then
            TransferSheetControls wSheet, CurrentCompass, NewCompass
        
                
        ElseIf wSheet.CodeName = "WorkPack" Or wSheet.CodeName = "Sheet2" Then
            updateCustomSheet wSheet, CurrentCompass, NewCompass, absRefference
        
        Else
            AddNewWorkSheets wSheet, CurrentCompass, NewCompass, absRefference
        End If
        
        
    
    Next
    
    Workbooks(TempFileName).Close savechanges:=False

    Application.ScreenUpdating = True


End Sub
Private Sub AddNewWorkSheets(wSheet, CurrentCompass, NewCompass, absRefference)
'####################################################################################################################
'
'
'####################################################################################################################
    sheetFound = False
    For Each ActiveSheets In CurrentCompass.Sheets
        If ActiveSheets.CodeName = wSheet.CodeName Then
            sheetFound = True
            Exit For
            
        End If
    
    Next
    If Not (sheetFound) Then
        
        Visibility = wSheet.Visible
        wSheet.Visible = True
        
        wSheet.Copy after:=CurrentCompass.Sheets(CurrentCompass.Worksheets.Count)
        
        CurrentCompass.Sheets(wSheet.Name).Cells.Replace what:=absRefference, replacement:="", lookat:=xlPart, MatchCase:=False
        CurrentCompass.Sheets(wSheet.Name).Cells.Replace what:="'" & CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & NewCompass.Name & "'!", replacement:="", lookat:=xlPart, MatchCase:=False
                
        CurrentCompass.Sheets(wSheet.Name).Visible = Visibility
        wSheet.Visible = Visibility
            
    End If
        


End Sub























Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_Activate()
ermsg = "Unknown Error"
On Error GoTo erHandel

1   Application.Calculation = xlCalculationManual
2   Application.ScreenUpdating = False
3   If Not IsError(Application.Caller) Then CampMini.Show
 

4   Application.Calculation = xlCalculationAutomatic
5   Application.ScreenUpdating = True
6   Application.Cursor = xlDefault

Exit Sub
erHandel:
erorEmail Application.VBE.ActiveCodePane.CodeModule.Name, ermsg, "Worksheet_Activate", erl
hitError 0, ermsg


End Sub

Sub updateRecs()
ermsg = "Unknown Error"
On Error GoTo erHandel
Application.Calculation = xlCalculationAutomatic
1   Application.Calculation = xlCalculationManual
2   Application.Cursor = xlWait
3   Application.ScreenUpdating = False
    Application.EnableEvents = False
    
4   Set rec = Sheet3
5   Set tbl = Sheet3.ListObjects("TblminiProcess")
6   Set WS = Sheet2


Sheet2.Unprotect Password:="Password"
7   WS.Range("G8:H500").ClearContents


15  manurow = 8

16  Do While WS.Cells(manurow, 2).Value <> ""
17      Set c = Nothing
18      ID = WS.Cells(manurow, 13).Value
19      With tbl.Range.Columns(15)
20          Set c = .Find(ID, LookIn:=xlValues, lookat:=xlWhole)
21          If Not c Is Nothing Then
22              firstaddress = c.Address
23              lastAddress = 0
24              lastDate = 0
25              mostRecentRow = 0
26              Count = 0
27              Do
28                  If firstaddress = c.Address And Count > 0 Then
                    'looped through
29                      WS.Cells(manurow, 7).Value = rec.Cells(mostRecentRow, 12).Value
30                      If rec.Cells(mostRecentRow, 13).Value <> "" Then WS.Hyperlinks.Add Anchor:=WS.Range("H" & manurow), Address:=rec.Cells(mostRecentRow, 13).Hyperlinks(1).Address, TextToDisplay:=rec.Cells(mostRecentRow, 13).Hyperlinks(1).TextToDisplay
31
                        WS.Cells(3, 6).Value = rec.Cells(mostRecentRow, 7).Value
                        WS.Cells(4, 6).Value = rec.Cells(mostRecentRow, 8).Value
                        WS.Cells(4, 9).Value = rec.Cells(mostRecentRow, 9).Value
                        Exit Do
32                  End If
                
33                  If lastDate < rec.Cells(c.Row, 14).Value Then
34                      mostRecentRow = c.Row
35                  End If
36                  Count = Count + 1
37                  lastAddress = c.Address
38                  lastDate = rec.Cells(c.Row, 14).Value
39                  Set c = .FindNext(c)
40              Loop While Not c Is Nothing
41          End If
42      End With
43      manurow = manurow + 1
44  Loop

Sheet2.Protect Password:="Password"

45  Application.Calculation = xlCalculationAutomatic
46  Application.ScreenUpdating = True
47  Application.Cursor = xlDefault
    Application.EnableEvents = True
    
Exit Sub
erHandel:
erorEmail Application.VBE.ActiveCodePane.CodeModule.Name, ermsg, "updateRecs", erl
hitError 0, ermsg



End Sub


Private Sub Worksheet_Change(ByVal target As Range)
ermsg = "Unknown Error"
On Error GoTo erHandel

1   Application.EnableEvents = False
2   Application.StatusBar = "Updating results"
3   Application.Cursor = xlWait
4   Application.Calculation = xlCalculationManual

5   Set WS = ActiveSheet
6   missData = False
'check cells have been filled in
If target.Column = 9 And target.Row = 3 Then

Sheet2.Unprotect Password:="Password"
    Sheet2.Range("G8:H500").ClearContents
    updateRecs
    

Sheet2.Protect Password:="Password"

7   ElseIf target.Column > 2 And target.Column < 11 Then
8       If target.Row > 2 And target.Row < 6 Then
9           For i = 3 To 5
10              If WS.Cells(i, 3).Value = "" Then missData = True
11              If WS.Cells(i, 6).Value = "" Then missData = True
12              If WS.Cells(i, 9).Value = "" Then missData = True
13          Next
        
14       If target.Address <> "$I$3" Then updateValues target
        
15      End If
16  End If

17  If target.Column > 6 And target.Column < 9 Then
18      If target.Row > 7 Then
19          If WS.Cells(target.Row, 2).Value <> "" Then updatemini target
20      End If
21  End If


22  Application.EnableEvents = True
23  Application.StatusBar = False
24  Application.Cursor = xlDefault
25  Application.Calculation = xlCalculationAutomatic

Exit Sub
erHandel:
erorEmail Application.VBE.ActiveCodePane.CodeModule.Name, ermsg, "Worksheet_Change", erl
hitError 0, ermsg

End Sub
Sub updateValues(ByVal target As Range)


tmpID = 0
myar = Application.Transpose(Application.Index(Sheet3.Range("P:P"), 0, 1))
fnd = Sheet2.Cells(3, 3).Value & "-" & Sheet2.Cells(4, 3).Value & "-" & Sheet2.Cells(5, 6).Value & "-" & Sheet2.Cells(5, 3).Value
tmpID = UBound(Filter(myar, fnd)) + 1



 
  For Each rw In Sheet3.ListObjects(1).DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible)

    If tmpID = 0 Then
    
        Sheet3.Cells(rw.Row, 1).Value = Sheet2.Name 'Name
        Sheet3.Cells(rw.Row, 2).Value = Sheet2.Cells(5, 9).Value 'Verions
        Sheet3.Cells(rw.Row, 3).Value = Sheet2.Cells(5, 3).Value 'Stage Number
        Sheet3.Cells(rw.Row, 4).Value = Sheet2.Cells(5, 6).Value 'Camp Number
        Sheet3.Cells(rw.Row, 5).Value = Sheet2.Cells(3, 3).Value 'Manufacture
        Sheet3.Cells(rw.Row, 6).Value = Sheet2.Cells(4, 3).Value 'Site
        Sheet3.Cells(rw.Row, 7).Value = Sheet2.Cells(3, 6).Value 'Manu date
        Sheet3.Cells(rw.Row, 8).Value = Sheet2.Cells(4, 6).Value 'Quanity
        Sheet3.Cells(rw.Row, 9).Value = Sheet2.Cells(4, 9).Value 'Usage
    
    Else
    
        Sheet3.Cells(rw.Row, 1).Value = Sheet2.Name 'Name
        Sheet3.Cells(rw.Row, 2).Value = Sheet2.Cells(5, 9).Value 'Verions
        Sheet3.Cells(rw.Row, 7).Value = Sheet2.Cells(3, 6).Value 'Manu date
        Sheet3.Cells(rw.Row, 8).Value = Sheet2.Cells(4, 6).Value 'Quanity
        Sheet3.Cells(rw.Row, 9).Value = Sheet2.Cells(4, 9).Value 'Usage
        
    End If
    
    lstrow = rw.Row

Next

If tmpID <> 0 Then
    If target.Column = 3 And target.Row = 3 Or target.Column = 3 And target.Row = 4 Or target.Column = 3 And target.Row = 5 Or target.Column = 6 And target.Row = 5 Then
        MsgBox "Could not change key manufacture infromation as this manufacture already exists" '& Chr(13) & "try changing the version number"
        
        Sheet2.Unprotect Password:="Password"
        Sheet2.Cells(5, 3).Value = Sheet3.Cells(lstrow, 3).Value 'Stage Number
        Sheet2.Cells(5, 6).Value = Sheet3.Cells(lstrow, 4).Value  'Camp Number
        Sheet2.Cells(3, 3).Value = Sheet3.Cells(lstrow, 5).Value 'Manufacture
        Sheet2.Cells(4, 3).Value = Sheet3.Cells(lstrow, 6).Value 'Site
        Sheet2.Protect Password:="Password"
    End If
    
End If




Sheet3.ListObjects(1).AutoFilter.ShowAllData

Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=1, Criteria1:=Sheet2.Name 'Sheet name
Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=2, Criteria1:=Sheet2.Cells(5, 9).Value 'Version
Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=3, Criteria1:=Sheet2.Cells(5, 3).Value 'Stage Number
Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=4, Criteria1:=Sheet2.Cells(5, 6).Value 'Camp NUmber
Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=5, Criteria1:=Sheet2.Cells(3, 3).Value 'Manufacture
Sheet3.ListObjects(1).DataBodyRange.AutoFilter field:=6, Criteria1:=Sheet2.Cells(4, 3).Value 'Site






End Sub
Sub updatemini(ByVal target As Range)
lstrow = Sheet3.ListObjects(1).ListRows.Count + 1

For i = 0 To target.Cells.Count - 1
    rw = target.Row + i
   ' sheet3.ListObjects(1).DataBodyRange.
   
    Sheet3.Cells(lstrow + 1 + i, 1).Value = Sheet2.Name 'Name
    Sheet3.Cells(lstrow + 1 + i, 2).Value = Sheet2.Cells(5, 9).Value 'Verions
    Sheet3.Cells(lstrow + 1 + i, 3).Value = Sheet2.Cells(5, 3).Value 'Stage Number
    Sheet3.Cells(lstrow + 1 + i, 4).Value = Sheet2.Cells(5, 6).Value 'Camp Number
    Sheet3.Cells(lstrow + 1 + i, 5).Value = Sheet2.Cells(3, 3).Value 'Manufacture
    Sheet3.Cells(lstrow + 1 + i, 6).Value = Sheet2.Cells(4, 3).Value 'Site
…