Updating vba code to point to a different sharepoint file to pull data

Hi, I am trying to update a macro to refresh a file with data from a SharePoint site, but my employer wants to change to a different project file within the SharePoint location, can anyone help as I have no idea! The code is very long....any pointers greatly received!

Option Explicit
'Public Variables
Public intDaysMonth As Integer          'Used to pass number of days in a defined month
Public intColumnLeft As Integer         'Used to pass the left value of a column
Public intColumnWidth As Integer        'Used to pass the width value of a column
Public lngRowTop As Long             'Used to pass the top value of a row
Public intRowHeight As Integer          'Used to pass the height value of a row
Public intGenericCounter As Integer     'Used within arrays and loops
Public varShapeArray(10)                'Variant array used to hold the required shapes for a single milestone entry
Public intShapeCount As Integer         'Used to hold number of shapes for a single milestone entry
Public blnTickTrue As Boolean           'Used to indicate if a tick was added
Public blnContinue As Boolean           'Used to determine if chart build should continue beyond the user preferences dialog
Dim blnOrder As Boolean                 'Used to determine whether to perform send to back operation on shapes
Dim intItemRowCounter As Integer

Public Sub GenerateChart()
    Dim rngTaskHeader As Range
    Set rngTaskHeader = Sheets("Plan").Range("B3")
    intItemRowCounter = rngTaskHeader.CurrentRegion.Rows.Count - 1
    Call GenerateChart_Process
End Sub
Private Sub GenerateChart_Process()
'*************************************************************************************************************
'PURPOSE: Generates a Milestone Chart on the "Chart" sheet based on data held in the "Plan" worksheet
'DEVELOPER: Originally written by an unknown developer, but amended by Andy Ives
'*************************************************************************************************************

Dim ChartDisplay As cls_ChartDisplay
Set ChartDisplay = New cls_ChartDisplay

'CONFIGURATION PREFERENCES:
'*******************************
'User Preferences
'-----------------
Dim strProjectName As String                    'Project Name
Dim blnIncludeKey As Boolean                    'Used to determine whether to include Key on the chart - USER CONFIGURATION PREFERENCE
                                                'INCLUDE KEY FUNCTIONALITY NOT CURRENTLY INCLUDED
Dim intCriticalView As Integer
Dim blnUseColours As Boolean                    'Used to determine if full colour is required on the chart
Dim blnUseRAGLetter As Boolean                  'Used to determine if the RAG Letter should be shown IN a milestone
Dim blnExport As Boolean                        'Used to determine if the user wants to export the results
Dim blnExportFormatXLS As Boolean               'Used to determine if the user wants to export in Excel format
Dim blnExportFormatPPT As Boolean               'Used to determine if the user wants to export in PowerPoint format

'Other settings required by the code, but not directly user defined
'-------------------------------------------------------------------
Dim intHistoryToShow As Integer                 'The number of months backward to show - USER CONFIGURATION PREFERENCE
Dim intMonthsForward As Integer                 'The number of months forward to show - USER CONFIGURATION PREFERENCE
Dim intWrapLength As Integer                    'TRUNCATES LENGTH OF DATA AND USED IN WRAPPING - NEED TO WATCH THIS ONE
Dim intDefaultColumnWidth As Integer            'The default column width for the chart sheet
Dim intMinRowHeight As Integer                  'Minimum Row Height to be used - CONFIGURATION PREFERENCE
Dim intTopPad As Integer                        'Used to hold padding at the top of a task - CONFIGURATION PREFERENCE
Dim intMidPad As Integer                        'Used to hold padding between milestones - CONFIGURATION PREFERENCE
Dim intBottomPad As Integer                     'Used to hold padding at the bottom of a task - CONFIGURATION PREFERENCE
Dim intMilestoneSize As Integer                 'Used to pass milestone size - CONFIGURATION PREFERENCE
Dim filename As String                          'Used in the PrintPDF sub to define filename

'INTEGERS
'********
Dim intRowCount As Integer                      'Used to count the number of rows in the source data
Dim intChartRows As Integer                     'Used to count the number of rows in chart output
Dim intMilestoneDay As Integer                  'Used to hold the day number from a milestone date
Dim intColour As Long                           'Used to pass colours
Dim intEndPoint As Integer                      'Used in determining where lines / milestones must end on the chart
Dim intNumProjects As Integer                   'Used to count the number of unique projects used in the milestone data
Dim intDaysBack As Integer                      'Used to count back a specific number of days from current date to define dtmMinDate
Dim intCounter As Integer                       'Used as a General Purpose Counter
Dim intProjectCount As Integer                  'Counts number of projects
Dim intProjectCountForFind As Integer           'NEED TO CONFIRM WHAT THIS DOES
Dim intMonthsToInclude As Integer               'The number of months to include in the chart
Dim intRAcount As Integer                       'NEED TO CONFIRM WHAT THIS DOES AND RENAME
Dim intMonthLabelCounter As Integer             'Used as a counter of the month labes included on the chart output
Dim lngMaxHeight As Long                     'Used to control maximum row height - NEED TO CONFIRM IF IT WORKS - APPEARS NOT TOO!!!
Dim intStartPoint As Integer                    'Used in when adding slippage line to the chart
Dim intDistance As Integer                      'Referred to in ADD LINE PROCEDURES, but appears not to be used
Dim intMaxMilestonesPerRow As Integer           'Maximum number of milestones it is possible to include in a row
Dim intMilesCount As Integer                    'Number of milestones contained in each Task
Dim intShapeGroupingIndex As Integer            'Used in grouping objects relating to a single milestone together
Dim intOverlapIndex As Integer                  'Used when checking for any shape overlap when cons
Dim lngPreTop As Long                        'All "intPre" and "intNew" variables used in the repositioning of chart items
Dim lngPreBottom As Long
Dim lngNewTop As Long
Dim lngNewBottom As Long
Dim intPreLeft As Integer
Dim intPreRight As Integer
Dim intNewLeft As Integer
Dim intNewRight As Integer
Dim lngLineLength As Long                    'Used to define the length of the "Today" line on the chart
Dim intTodayDay As Integer                      'Used to determine the Day of the current month when adding the "Today" line
Dim intDay100Day As Integer                     'Used to determine the Day of the current month when adding the "Day 100" line
Dim intDay1Day As Integer                   'Used to determine the Day of the current month when adding the "Day 1" line
Dim lngMergeCellHeight As Long               'Used to determine the height to merge cells to
Dim intMergeCounter As Integer                  'Counter used in the cell merge
Dim intErrorTableRows As Integer                'Used to capture the number of rows in the error log
                                            
'SINGLE
'******
Dim sngProportionOfMonth As Single              'Used to determine the proportion of the month that has passed at milestone date
Dim sngDistanceIn As Single                     'Used to determine the Distance into the cell for the milestone
Dim sngDistanceIn2 As Integer                   'Used to determine the distance into the cell where there are new/old milestones
Dim sngProportion As Single                     'Used when determining the proportion through the month for the "Today" line
Dim sngTodayDistIn As Single                    'Used to determine the distance into the cell the "Today" line needs to be put at


'DATE/TIMES
'**********
Dim dtmCurrentDate As Date                      'Used to hold the current date
Dim dtmMilestoneDate As Date                    'Used to hold the date for the milestone
Dim dtmEndDate As Date                          'Used to hold the maximum date to be used in the milestone data
Dim dtmStartDate As Date                        'Used to hold the Start Date for the chart
Dim dtmMinDate As Date                          'Used to hold the Minimum Date we want to start from. This limits where the Start Date will be allowed to begin

'BOOLEAN
'*******
Dim blnNewTask As Boolean                       'Flag denoting a "New Task" in the data array
Dim blnOverlapA As Boolean                      'Flag that denotes where there is an overlap on chart milestones
Dim blnOverlapB As Boolean                      'Flag that denotes where there is an overlap on chart milestones

'STRING
'******
Dim strPageSetUpTitle As String                 'POINTS TO AN EMPTY CELL IN THE ORIGINAL CODE AND IS NOT REFERRED TO BEYOND THAT REFERENCE
Dim strRowRef1 As String                        'Used to hold a cell reference for known rows as part of Merge Cells section
Dim strRowRef2 As String                        'Used to hold a cell reference for known rows as part of Merge Cells section
Dim strMergeRange1 As String                    'NEED TO CONFIRM WHAT THIS IS FOR
Dim strMergeRange2 As String                    'NEED TO CONFIRM WHAT THIS IS FOR
Dim strLabelValue As String                     'Value to be used in the label
Dim strFindTask As String                       'Task used in find
Dim strRAGLetter As String                      'The First Character of the RAG Status used to add the letter to the milestone

'VARIANT
'*******
Dim varStoneData()                       'Used to hold milestone data - Fixed 400 / 11 Dimensions
ReDim varStoneData(intItemRowCounter, 11)                                                 'Dimension 1 represents up to 400 rows of input data
                                                'Dimension 2 represents the column data items from columns B to L of the data sheet
Dim varPositionArray()
ReDim varPositionArray(intItemRowCounter, 4) 'Used to hold position of milestones & task names
Dim MaxMS As Variant

'OBJECT
'*******
Dim wsPreferences As Worksheet                  'Worksheet in the workbook containing user defined preferences
Dim wsChart As Worksheet                        'The chart worksheet in the worksbook
Dim wsPlan As Worksheet                         'The Plan worksheet in the workbook
Dim wsErrorLog As Worksheet                     'The Error Log Worksheet
Dim shpMilestoneShapeType As MsoAutoShapeType   'Used to hold the type of milestone shape
Dim rngFoundProject As Range                    'Range object referring to where the project appears in the spreadsheet
Dim rngShapeTargetRange As Range                'Range object which determines where shapes need to be added
Dim rngTaskHeader As Range                      'Range object used to denote the top of the Task Column on the data sheet
Dim rngProjectHeader As Range                   'Range object used to denote the top of the Project Name Column
Dim rngChartColumnLabelStart As Range           'Range object used to denote the starting point for the month labels on the chart
Dim rngChartRowLabelStart As Range              'Range object used to denote the starting point for the Project Labels on the chart



'ERROR HANDLER
'*********************************************************************************************************
'On Error GoTo GenerateChart_Error:

'SCREEN UPDATES OFF
'*********************************************************************************************************
Application.ScreenUpdating = False

Call testTimer("Start of Chart Generator")

'SET VARIABLES FOR USER DEFINED PREFERENCES
'*********************************************************************************************************
'User defined preferences are stored on the Variables sheet.
Set wsPreferences = ThisWorkbook.Sheets("Preferences")

'User Preferences
strProjectName = wsPreferences.Range("C2").Value
blnIncludeKey = wsPreferences.Range("C3").Value
blnUseColours = wsPreferences.Range("C4").Value
blnUseRAGLetter = wsPreferences.Range("C5")
intHistoryToShow = wsPreferences.Range("C6").Value
intMonthsForward = wsPreferences.Range("C7").Value
blnExport = wsPreferences.Range("C8").Value
blnExportFormatXLS = wsPreferences.Range("C9").Value
blnExportFormatPPT = wsPreferences.Range("C10").Value

'Other preferences (not directly edited by user)
intWrapLength = wsPreferences.Range("C11").Value
intDefaultColumnWidth = wsPreferences.Range("C12").Value
intMinRowHeight = wsPreferences.Range("C13").Value
intTopPad = wsPreferences.Range("C14").Value
intMidPad = wsPreferences.Range("C15").Value
intBottomPad = wsPreferences.Range("C16").Value
intMilestoneSize = wsPreferences.Range("C17").Value

intCriticalView = wsPreferences.Range("C20").Value
'SET OTHER VARIABLES
'*********************************************************************************************************
'intMaxMilestonesPerRow: Maximum row height of an Excel row is 409 points, therefore maximum number of
'stones in one row is 409 minus top and bottom padding, divided by number of milestones and with mid madding
'padding between each
'In practice, using 409 has caused some errors where there are lots of milestones in the same workstream.
'Using 300 as a row height reduces the number of milestones per row, but resolves the issues
intMaxMilestonesPerRow = Int((300 - (intTopPad + intBottomPad)) / (intMilestoneSize + intMidPad))

'End Date for chart to be started as Today's Date plus the number of days forward
dtmEndDate = Sheets("Workplan").Range("N5").Value

'Start date for the chart to be started as Today's Date minus the number of Months to show
dtmStartDate = Sheets("Workplan").Range("N3").Value

Set rngTaskHeader = Sheets("Plan").Range("B3")      'Task Header Cell on the Plan Sheet
Set rngProjectHeader = Sheets("Plan").Range("G3")   'Project Name Header Cell on the Plan Sheet
intCounter = 1                                      'Start Counter at 1
Set wsChart = ThisWorkbook.Worksheets("Chart")      'Chart Worksheet
Set wsPlan = ThisWorkbook.Worksheets("Plan")        'Plan Worksheet

Set rngChartColumnLabelStart = wsChart.Range("D2")  'Start point on the Chart Worksheet for the month labels
Set rngChartRowLabelStart = wsChart.Range("C3")     'Start point on the chart worksheet for the project labels


' ARRAY LOAD PROCESS: Aims to load all data from the spreadsheet into an array for later manipulation.
'*****************************************************************************************************
'STEP 1 - Check the number of rows in the source data
'----------------------------------------------------
'Count the number of rows in the source data
Call testTimer("Step 1")
intRowCount = rngTaskHeader.CurrentRegion.Rows.Count - 1

If intRowCount = 0 Then
    MsgBox ("No Data")
GoTo GenerateChart_Exit
End If

    Select Case intItemRowCounter
        Case Is < 500
        Case Is < 1000
            MaxMS = MsgBox("You are attempting to produce a large chart this may take ~10mins Do you want to continue?", vbYesNo, "Milestone Warning")
            If MaxMS = vbNo Then GoTo GenerateChart_Exit
        Case Is < 2000
            MaxMS = MsgBox("You are attempting to produce an extremely large chart this may take ~20mins Do you want to continue?", vbYesNo, "Milestone Warning")
            If MaxMS = vbNo Then GoTo GenerateChart_Exit
        Case Is > 2000
            MaxMS = MsgBox("WOAH!!!!!  This will be a HUGE chart and may take many hours to produce (Chart Algo ~O(N^2)) Do you want to continue? (Hint if you're unsure press no and filter your chart more)", vbYesNo, "Milestone Warning")
            If MaxMS = vbNo Then GoTo GenerateChart_Exit
    End Select

'STEP 2 - Milestone Check / Data Amendment
'------------------------------------------
'intMaxMilestonesPerRow states how many milestones a row on the chart sheet can accept.
'This checks the number of milestones in each task. Where the number of milestones exceeds the maximum possible
'for a chart row, the Task Name in column B is changed so it's milestones will appear in a new row on the chart sheet.
'The data from the Task Name List is copied so it can be added back later.

'Ensure on correct sheet and copy source data
With wsPlan
    .Activate
    .Range("B4", Range("B4").End(xlDown)).Copy
    .Range("A4").PasteSpecial
End With


'Milestone Check / Data Amendment
Do While intCounter <= intRowCount
    'Offset down from the Task Header by the same value as the counter. Compare the cell with an offset
    'of counter plus one. This will determine where Tasks change.
    If rngTaskHeader.Offset(intCounter, 0) = rngTaskHeader.Offset(intCounter + 1, 0) Then
        'compare with the offset down of counter plus milestone count
        Do While rngTaskHeader.Offset(intCounter, 0) = rngTaskHeader.Offset(intCounter + intMilesCount, 0)
           'While the two offsets are the same, increment milestone counter by 1
           intMilesCount = intMilesCount + 1
        Loop
        'Check the count of milestones against the maximum milestones number
        If intMilesCount >= intMaxMilestonesPerRow Then
            For intRAcount = intMaxMilestonesPerRow To intMilesCount - 1
                rngTaskHeader.Offset(intCounter + intRAcount, 0) = rngTaskHeader.Offset(intCounter + intRAcount, 0) & intCounter
            Next intRAcount
            intCounter = intCounter + (intMaxMilestonesPerRow - 1)
        End If
    End If
    intCounter = intCounter + 1
    intMilesCount = 0
Loop


'STEP 4 - CHECK FOR THE NUMBER OF PROJECTS
'-----------------------------------------
intCounter = 1
intProjectCount = 1

Do Until intCounter = intRowCount
    If rngProjectHeader.Offset(intCounter, 0) <> rngProjectHeader.Offset(intCounter + 1, 0) Then
        intProjectCount = intProjectCount + 1
    End If
    
intCounter = intCounter + 1

Loop

'STEP 5 - LOAD DATA INTO MILESTONE DATA ARRAY
'--------------------------------------------
'Ensure correct sheet selected and correct cell selected
With wsPlan
    .Activate
    .Range("B4").Select
End With

Do While intGenericCounter <= intRowCount

    'TASK (COLUMN B)
    varStoneData(intGenericCounter, 0) = ActiveCell.Value
    
    'SUB-TASK (COLUMN C)
    varStoneData(intGenericCounter, 1) = Left(ActiveCell.Offset(0, 1).Value, intWrapLength - 7)
    
    'MILESTONE DATE (COLUMN D)
    varStoneData(intGenericCounter, 2) = ActiveCell.Offset(0, 2).Value
    
    'RESETS THE END DATE VARIABLE TO THE LAST DATE IN THE DATA TO BE DELIVERED
    If intGenericCounter > 0 Then
        'If the active cell contains a date that is after dtmEndDate, change dtmEndDate to the current value plus the number of months forward to show
        If ActiveCell.Offset(0, 2).Value > dtmEndDate And IsDate(ActiveCell.Offset(0, 2).Value) Then
            dtmEndDate = DateSerial(Year(ActiveCell.Offset(0, 2).Value), Month(ActiveCell.Offset(0, 2).Value), daysinmonth(Month(ActiveCell.Offset(0, 2).Value))) + ((intMonthsForward) * 30)
        End If
        'If the active cell contains a date that is before dtmStartDate, change it to the current value minus the number of months history to show
        If ActiveCell.Offset(0, 2).Value < dtmStartDate And IsDate(ActiveCell.Offset(0, 2).Value) Then
            dtmStartDate = DateSerial(Year(ActiveCell.Offset(0, 2).Value), Month(ActiveCell.Offset(0, 2).Value), daysinmonth(Month(ActiveCell.Offset(0, 2).Value))) - ((intHistoryToShow) * 30)
        End If
    End If
        
    'Primary (COLUMN E)
    varStoneData(intGenericCounter, 3) = ActiveCell.Offset(0, 3).Value
    
    'RAG STATUS (COLUMN F)
    varStoneData(intGenericCounter, 4) = ActiveCell.Offset(0, 4).Value
    
    'CRITICAL STATUS(COLUMN G)
    If InStr(ActiveCell.Offset(0, 5).Value, "Yes - Integration") > 0 Then
        varStoneData(intGenericCounter, 5) = 1
    ElseIf InStr(ActiveCell.Offset(0, 5).Value, "Yes - Synergy") > 0 Then
        varStoneData(intGenericCounter, 5) = 2
    Else
        varStoneData(intGenericCounter, 5) = 0
    End If
    
    'OLD DATE (COLUMN H)
    'Need to ensure that chart is allowed to start at the point where the old milestones begin so
    'change dtmStartDate accordingly
    varStoneData(intGenericCounter, 6) = ActiveCell.Offset(0, 6).Value
    
    'If the active cell contains a date that is before dtmStartDate, change it to the current value
    If ActiveCell.Offset(0, 6).Value < dtmStartDate And IsDate(ActiveCell.Offset(0, 6).Value) Then
        dtmStartDate = DateSerial(Year(ActiveCell.Offset(0, 6).Value), Month(ActiveCell.Offset(0, 6).Value), daysinmonth(Month(ActiveCell.Offset(0, 6).Value)))
    End If
        
'    'MILESTONE TYPE - THE RULES HERE GENERATE A NUMBER WHICH DETERMINES THE MILESTONE TYPE WHEN ADDING TO CHART
'    'Check to see if Sub-Task begins with "Key" or "Critical"
'    If Left(ActiveCell.Offset(0, 1), 3) = "Key" Then varStoneData(intGenericCounter, 7) = 3 Else varStoneData(intGenericCounter, 7) = 0
'    If Left(ActiveCell.Offset(0, 1), 8) = "Critical" Then varStoneData(intGenericCounter, 7) = 4
        
'    'Check whether it is a Gating or Release Task
'    'NB - THIS WILL OVERWRITE KEY OR CRITICAL ITEMS AS DEFINED ABOVE
    If ActiveCell.Offset(0, 9).Value = "Level 0" Then varStoneData(intGenericCounter, 7) = 1
    If ActiveCell.Offset(0, 9).Value = "Level 1" Then varStoneData(intGenericCounter, 7) = 2
    If ActiveCell.Offset(0, 9).Value = "Level 2" Then varStoneData(intGenericCounter, 7) = 3
            
    'PROGRAMME (COLUMN I)
    varStoneData(intGenericCounter, 8) = ActiveCell.Offset(0, 7).Value
    
    'TEXT_VALUE (COLUMN K)
    varStoneData(intGenericCounter, 9) = ActiveCell.Offset(0, 9).Value
         
    'MILESTONE COLOUR REFERENCE
    'If User Preference is to use Colour,then store the colour for the milestone
    If blnUseColours = True Then
        'Check the Status Colour and assign the appropriate color
        Select Case StrConv(ActiveCell.Offset(0, 4), vbProperCase)
            Case "1 - Green"
                varStoneData(intGenericCounter, 10) = 5296274
            Case "2 - Amber"
                varStoneData(intGenericCounter, 10) = 65535
            Case "3 - Red"
                varStoneData(intGenericCounter, 10) = 192
            Case "4 - Complete"
                varStoneData(intGenericCounter, 10) = 0
            Case Else
                varStoneData(intGenericCounter, 10) = 14277081
        End Select
'        'Change the color for Critical or Key milestones
'        If StrConv(Left(ActiveCell.Offset(0, 1), 8), vbProperCase) = "Critical" Then varStoneData(intGenericCounter, 10) = RGB(230, 56, 230)
'        If StrConv(Left(ActiveCell.Offset(0, 1), 8), vbProperCase) = "Critical" And ActiveCell.Offset(intGenericCounter, 8).Value = "Grey" Then varStoneData(intGenericCounter, 10) = RGB(0, 0, 0)
'        If StrConv(Left(ActiveCell.Offset(0, 1), 3), vbProperCase) = "Key" Then varStoneData(intGenericCounter, 10) = RGB(26, 196, 236)
'        If StrConv(Left(ActiveCell.Offset(0, 1), 3), vbProperCase) = "Key" And ActiveCell.Offset(intGenericCounter, 3).Value = "Grey" Then varStoneData(intGenericCounter, 10) = RGB(0, 0, 0)
    Else
        varStoneData(intGenericCounter, 10) = 14277081
    End If
    'MILESTONE COLOUR RAG LETTER
    If blnUseRAGLetter = True Then
        'Graham Rose did not want to use "B" if the item is complete - preferred the use of the tick character gained by adding "Complete" to column K
        If StrConv(Left(ActiveCell.Offset(0, 4), 1), vbUpperCase) <> "B" Then
            varStoneData(intGenericCounter, 11) = StrConv(Mid(ActiveCell.Offset(0, 4), 5, 1), vbUpperCase)
        End If
    End If
    intGenericCounter = intGenericCounter + 1
    Selection.Offset(1, 0).Select
Loop


    Call testTimer("Step 6 (Data in array)")

'STEP 6 - Re-calculate date variables so the right amount of time is shown
'--------------------------------------------------------------------------
'Sets the Start and End Date variables to the First of the Month for the milestones
dtmStartDate = DateSerial(Year(dtmStartDate), Month(dtmStartDate), 1)
dtmEndDate = DateSerial(Year(dtmEndDate), Month(dtmEndDate), 1)
intMonthsToInclude = ((Year(dtmEndDate) - Year(dtmStartDate)) * 12) + (Month(dtmEndDate) - Month(dtmStartDate)) + Int(intMonthsForward)
dtmMinDate = dtmCurrentDate - intDaysBack


'CHART SHEET PREPARATION PROCESS: Clears down previous chart data
'*****************************************************************************************************
wsChart.Select
With wsChart.Cells
    .Clear
    .MergeCells = False
    .Rows.RowHeight = intMinRowHeight
End With

'Remove all current milestones and shapes
If wsChart.Shapes.Count > 0 Then
    wsChart.Shapes.SelectAll
    Selection.Delete
End If

'Make Row A double intminrowheight
With wsChart.Range("A1").Select
Rows(1).RowHeight = 100
End With

'CHART BUILDING PROCESS: Creates the new milestone chart
'*****************************************************************************************************
'STEP 1 - Add column (month)labels and format
'--------------------------------------------

intMonthLabelCounter = 0

Do While intMonthLabelCounter < intMonthsToInclude + 1
    
    With rngChartColumnLabelStart
        .Offset(0, intMonthLabelCounter).Value = DateSerial(Year(dtmStartDate), Month(dtmStartDate) + intMonthLabelCounter, 1)
        .Offset(0, intMonthLabelCounter).NumberFormat = "mmm-yy"
        .Offset(0, intMonthLabelCounter).Interior.ColorIndex = 16
        .Offset(0, intMonthLabelCounter).Interior.Pattern = xlSolid
        .Offset(0, intMonthLabelCounter).Font.ColorIndex = 2
        .Offset(0, intMonthLabelCounter).Font.Bold = True
        .Offset(0, intMonthLabelCounter).Font.Size = intMilestoneSize * 1
        .Offset(0, intMonthLabelCounter).columnwidth = intDefaultColumnWidth
        .Offset(0, intMonthLabelCounter).HorizontalAlignment = xlCenter
        .Offset(0, intMonthLabelCounter).VerticalAlignment = xlCenter
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeLeft).Weight = xlHairline
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeLeft).ColorIndex = 0
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeRight).LineStyle = xlContinuous
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeRight).Weight = xlHairline
        .Offset(0, intMonthLabelCounter).Borders(xlEdgeRight).ColorIndex = 0
    End With
    
    intMonthLabelCounter = intMonthLabelCounter + 1
    
Loop
    Call testTimer("Chart Building (Months Added)")
'STEP 2: Add project labels
'--------------------------
'This loops through the varStoneData array and adds the project names to the sheet

intGenericCounter = 0
intNumProjects = 0
blnNewTask = True
rngChartRowLabelStart.Select

'Count through all indexes in the array that are less than the number of rows in the data
Do While intGenericCounter < intRowCount
        
    'If the blnNewTask is TRUE then add the values from the First Array Element to the sheet and format
    If blnNewTask Then
                      
            With ActiveCell
                .Value = varStoneData(intGenericCounter, 0)
                .Interior.ColorIndex = 15
                .Interior.Pattern = xlSolid
                .Font.ColorIndex = 1
                .Font.Bold = True
                .Font.Size = intMilestoneSize * 1
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .ShrinkToFit = False
                .MergeCells = False
                '.Font.Size = intMilestoneSize * 1
            End With
            
            intNumProjects = intNumProjects + 1
            
            ActiveCell.Offset(1, 0).Select
        
    End If
    
    'Check to see if the next item in the array is a new project and set the blnNewTask accordingly
    If varStoneData(intGenericCounter, 0) <> varStoneData(intGenericCounter + 1, 0) Then
        blnNewTask = True
    Else
        blnNewTask = False
    End If
    intGenericCounter = intGenericCounter + 1
    
Loop

'STEP 2.5: Add project labels
'--------------------------
'This loops through the varStoneData array and adds the project names to the sheet

intGenericCounter = 0
intNumProjects = 0
blnNewTask = True
Worksheets("Chart").Range("B3").Select

'Count through all indexes in the array that are less than the number of rows in the data
Do While intGenericCounter < intRowCount

    'If the blnNewTask is TRUE then add the values from the First Array Element to the sheet and format
    If blnNewTask Then

            With ActiveCell
                .Value = varStoneData(intGenericCounter, 8)
                .Interior.ColorIndex = 15
                .Interior.Pattern = xlSolid
                .Font.ColorIndex = 1
                .Font.Bold = True
                .Font.Size = intMilestoneSize * 1
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .ShrinkToFit = False
                .MergeCells = False
                '.Font.Size = intMilestoneSize * 1
            End With

            intNumProjects = intNumProjects + 1

            ActiveCell.Offset(1, 0).Select

    End If

    'Check to see if the next item in the array is a new project and set the blnNewTask accordingly
    If varStoneData(intGenericCounter, 0) <> varStoneData(intGenericCounter + 1, 0) Then
        blnNewTask = True
    Else
        blnNewTask = False
    End If
    intGenericCounter = intGenericCounter + 1

Loop


'STEP 2.6: Add project labels
'--------------------------
'This loops through the varStoneData array and adds the project names to the sheet

intGenericCounter = 0
intNumProjects = 0
blnNewTask = True
Worksheets("Chart").Range("A3").Select

'Count through all indexes in the array that are less than the number of rows in the data
Do While intGenericCounter < intRowCount

    'If the blnNewTask is TRUE then add the values from the First Array Element to the sheet and format
    If blnNewTask Then

            With ActiveCell
                .Value = varStoneData(intGenericCounter, 3)
                .Interior.ColorIndex = 15
                .Interior.Pattern = xlSolid
                .Font.ColorIndex = 1
                .Font.Bold = True
                .Font.Size = intMilestoneSize * 1
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .ShrinkToFit = False
                .MergeCells = False
                '.Font.Size = intMilestoneSize * 1
            End With

            intNumProjects = intNumProjects + 1

            ActiveCell.Offset(1, 0).Select

    End If

    'Check to see if the next item in the array is a new project and set the blnNewTask accordingly
    If varStoneData(intGenericCounter, 0) <> varStoneData(intGenericCounter + 1, 0) Then
        blnNewTask = True
    Else
        blnNewTask = False
    End If
    intGenericCounter = intGenericCounter + 1

Loop

    Call testTimer("Chart Building (labels Added)")

'STEP 3: Format the chart grid
'------------------------------

'DECIDE THE WIDTH OF COLUMN A
wsChart.Columns("C:C").EntireColumn.columnwidth = 45

With Range(rngChartColumnLabelStart, rngChartColumnLabelStart.Offset(intNumProjects, intMonthsToInclude))
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlHairline
    .Borders.ColorIndex = 1
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeTop).Weight = xlMedium
    .Borders(xlEdgeTop).ColorIndex = 1
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).Weight = xlMedium
    .Borders(xlEdgeBottom).ColorIndex = 1
        If intNumProjects > 1 Then
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).Weight = xlMedium
            .Borders(xlInsideHorizontal).ColorIndex = 1
        End If
End With

' Moved to before Milestones
Call ChartDisplay.AddLabelBorders

    Call testTimer("Chart Building (Add borders done)")
Call ChartDisplay.mergeMilestones
    Call testTimer("Chart Building (MergeMilestones Done)")

'ADD MILESTONE PROCESS: Adds milestones to the correct rows on the Chart Sheet.
'                       There are multiple steps within one master loop in this section.
'*******************************************************************************************************
'Reset variables
intGenericCounter = 0
lngMaxHeight = 0
blnNewTask = False

'STEP 1: Start Master Loop through the task data in the array and determine if the current task is a new one
'-----------------------------------------------------------------------------------------------------------
'Loop through all tasks
Do While intGenericCounter < intRowCount
    
    intShapeCount = 0
    blnTickTrue = False
    
    'Once the loop has completed once, check the next task in the array to see if it is the same as
    'the previous one and reset the blnNewTask variable accordingly
    If intGenericCounter > 1 Then
        If varStoneData(intGenericCounter, 0) <> varStoneData(intGenericCounter - 1, 0) Then
            blnNewTask = True
        Else
            blnNewTask = False
        End If
    End If
    
    'If we are on a new task, then
    If blnNewTask = True Then
        'Select the target range to put the milestones in
        rngShapeTargetRange.Select
        If lngMaxHeight > 400 Then
            Selection.RowHeight = lngMaxHeight - Selection.Top + intBottomPad
        Else
            If lngMaxHeight > 0 Then
                Selection.RowHeight = lngMaxHeight - Selection.Top + intBottomPad
            Else
                lngMaxHeight = intMinRowHeight
            End If
        End If
        lngMaxHeight = 0
    End If
    
    'STEP 2: Find the row on the chart to place the milestone in
    '------------------------------------------------------------
    'Set strFindTask to be the value of the Task Name in the array
    strFindTask = varStoneData(intGenericCounter, 0)
    
    'Select the appropriate start point on the sheet
    wsChart.Range("c2").Select
     
    If blnNewTask = True Then intProjectCountForFind = intProjectCountForFind + 1
    
    'Set the rngFoundProject variable to the point at which the Task Name is located
    Set rngFoundProject = Range("c:c").Find(strFindTask, ActiveCell.Offset(intProjectCountForFind, 0))
        
    'If project is not found, pass a message to the user
    If rngFoundProject Is Nothing Then
        MsgBox "Project " & varStoneData(intGenericCounter, 0) & " NOT FOUND" & Chr(13) & Chr(10) & " - Please check project on line " & intGenericCounter + 3, vbCritical, "Invalid Project"
        End
    Else
        rngFoundProject.Select
    End If
    
    'Identify the position of the top of the selected row
    Set rngShapeTargetRange = Selection
    lngRowTop = Selection.Top + intTopPad
    
    'Identify the height of the selected row
    intRowHeight = Selection.RowHeight
    
    'Find the appropriate date on the chart and return its postion
    If Not IsDate(varStoneData(intGenericCounter, 2)) Then
        varPositionArray(intGenericCounter, 4) = varStoneData(intGenericCounter, 0)
        GoTo endmainloop
    End If
    
    dtmMilestoneDate = varStoneData(intGenericCounter, 2)
    
    'Call the sub that works out column left and column top of the date cell
    Call DateToPosition(dtmMilestoneDate)
    
    ' Work out the proportion of the month which has passed at the milestone date
    intMilestoneDay = Day(varStoneData(intGenericCounter, 2))
    sngProportionOfMonth = (intMilestoneDay / intDaysMonth)
    
    ' Work out the position of the milestone by calculating the proportion of the column width and reducing for milestone size
    sngDistanceIn = (intColumnWidth * sngProportionOfMonth) - (intMilestoneSize + 1) / 2
        
    ' Define the milestone color from the colour of the milestone status cell
    intColour = varStoneData(intGenericCounter, 10)
            
    'Determine Milestone Type and set shape accordingly (ARRAY ELEMENT 7 BUSINESS RULES NEED SOME WORK)
    Select Case varStoneData(intGenericCounter, 7)
            
            Case 1: shpMilestoneShapeType = msoShapeRectangle
            Case 2: shpMilestoneShapeType = msoShapeOval
            Case 3: shpMilestoneShapeType = msoShapeDiamond
            Case Else: shpMilestoneShapeType = msoShapeIsoscelesTriangle
    
    End Select
    
    If intCriticalView = 1 Then
        Select Case varStoneData(intGenericCounter, 5)
            Case 1: shpMilestoneShapeType = msoShape5pointStar
            Case 2: shpMilestoneShapeType = msoShape5pointStar
            Case Else: ' Do nothing
        End Select
    End If
    'STEP 3: Prepare the Label for the Milestone and deal with word wrapping issues
    '------------------------------------------------------------------------------
    strLabelValue = varStoneData(intGenericCounter, 1) & " - " & CStr(intMilestoneDay) & "/" & CStr(Month(varStoneData(intGenericCounter, 2)))
    
    'If the label is longer than the wrap length
    If Len(strLabelValue) > intWrapLength Then
        
        'Put carriage returns into the label as required
        Dim position As Integer
        position = intWrapLength - 5
        
        Do While position < Len(strLabelValue)
            If Mid(strLabelValue, position, 1) = " " Then
                strLabelValue = Left(strLabelValue, position) & Chr(10) & Right(strLabelValue, Len(strLabelValue) - position)
                position = position + intWrapLength - 3
            End If
            position = position + 1
        Loop
    
    End If
    
    'STEP 4: Add the milestone given parameters calculated in step 2
    '---------------------------------------------------------------
    If varStoneData(intGenericCounter, 2) > dtmMinDate Then
    strRAGLetter = varStoneData(intGenericCounter, 11)
        
        Call AddMilestone(intColumnLeft + sngDistanceIn, lngRowTop, intMilestoneSize, intMilestoneSize, intColour, shpMilestoneShapeType, strRAGLetter)
        
        ' Create the comment box
        ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, intColumnLeft + sngDistanceIn + intMilestoneSize + intMilestoneSize * 0.2, lngRowTop + intMilestoneSize * 0.1, 98.25, 21#).Select
        With Selection
        If varStoneData(intGenericCounter, 7) = 1 Then
            .Characters.Text = strLabelValue
            .Font.Size = 1 * intMilestoneSize
            .Font.FontStyle = "Bold"
            If intCriticalView = 1 And varStoneData(intGenericCounter, 5) = 1 Then
                .Font.Color = vbBlue
            ElseIf intCriticalView = 1 And varStoneData(intGenericCounter, 5) = 2 Then
                .Font.Color = vbBlue
            ElseIf intCriticalView = 1 Then
                .Font.Color = vbBlack
            Else
                .Font.Color = vbBlack
            End If
            .ShapeRange.Fill.Visible = msoFalse
            .ShapeRange.Line.Visible = msoFalse
            .AutoSize = True
            .ShapeRange.TextFrame.MarginLeft = 0#
            .ShapeRange.TextFrame.MarginRight = 0#
            .ShapeRange.TextFrame.MarginTop = 0#
            .ShapeRange.TextFrame.MarginBottom = 0#
            .Placement = xlFreeFloating
            .Name = intGenericCounter & "." & intShapeCount
        Else
            .Characters.Text = strLabelValue
            .Font.Size = 1 * intMilestoneSize
            .Font.FontStyle = "Regular"
            .ShapeRange.Fill.Visible = msoFalse
            .ShapeRange.Line.Visible = msoFalse
            .AutoSize = True
            .ShapeRange.TextFrame.MarginLeft = 0#
            .ShapeRange.TextFrame.MarginRight = 0#
            .ShapeRange.TextFrame.MarginTop = 0#
            .ShapeRange.TextFrame.MarginBottom = 0#
            .Placement = xlFreeFloating
            .Name = intGenericCounter & "." & intShapeCount
        End If
        

        End With
        varShapeArray(intShapeCount) = Selection.Name
        intShapeCount = intShapeCount + 1
        
    End If

    'STEP 5: If the milestone date has moved insert the previous milestone and slippage arrow
    '----------------------------------------------------------------------------------------
    'Action to take if the milestone date has moved, but is after the value of the minimum allowable date for the chart
    If varStoneData(intGenericCounter, 6) > "" And varStoneData(intGenericCounter, 6) >= dtmMinDate And varStoneData(intGenericCounter, 6) < varStoneData(intGenericCounter, 2) Then
            blnOrder = False
            intEndPoint = intColumnLeft + sngDistanceIn
            dtmMilestoneDate = varStoneData(intGenericCounter, 6)
            Call DateToPosition(dtmMilestoneDate)
            intMilestoneDay = Day(varStoneData(intGenericCounter, 6))
            sngProportionOfMonth = (intMilestoneDay / intDaysMonth)
            sngDistanceIn2 = (intColumnWidth * sngProportionOfMonth) - (intMilestoneSize + 1) / 2
            intColour = 12632256
            
            'Insert the old milestone
            If varStoneData(intGenericCounter, 2) > dtmMinDate Then Call AddMilestone(intColumnLeft + sngDistanceIn2, lngRowTop, intMilestoneSize, intMilestoneSize, 192, shpMilestoneShapeType)
            intStartPoint = intColumnLeft + sngDistanceIn2 + intMilestoneSize
            'reset the flag to true
            blnOrder = True
            'Calculate the required start and end points for the slippage arrow
            intDistance = intEndPoint - intStartPoint
            intStartPoint = intStartPoint + intMilestoneSize * 0.5
            intEndPoint = intEndPoint - intMilestoneSize * 0.5
            
            'Insert the slippage arrow
            ActiveSheet.Shapes.AddLine(intStartPoint, lngRowTop + intMilestoneSize / 2, intEndPoint, lngRowTop + intMilestoneSize / 2).Select
            With Selection
                .ShapeRange.Name = intGenericCounter & "." & intShapeCount
                .ShapeRange.Line.Weight = 0.01
                .ShapeRange.Line.DashStyle = msoLineSquareDot
                .ShapeRange.Line.Style = msoLineSingle
                .ShapeRange.Line.Transparency = 0#
                .ShapeRange.Line.Visible = msoTrue
                .ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)           'Black arrows only
                .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)     'White background
                .ShapeRange.Line.BeginArrowheadLength = msoArrowheadNarrow
                .ShapeRange.Line.BeginArrowheadWidth = msoArrowheadWidthMedium
                .ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone
                .ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
                .ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
                .ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone
                .Placement = xlFreeFloating
            End With
            varShapeArray(intShapeCount) = Selection.Name
            intShapeCount = intShapeCount + 1
            
            'Add an arrow head shape manually to avoid sizing issues when pasting to word
            If varStoneData(intGenericCounter, 2) > dtmMinDate Then Call AddMilestone(intEndPoint - intMilestoneSize * 0.3, lngRowTop + intMilestoneSize * 0.25, intMilestoneSize / 2, intMilestoneSize / 2, 192, msoShapeIsoscelesTriangle)
            Selection.ShapeRange.IncrementRotation 90#
        
        End If
      
        'Action to take if the Milestone has moved and the Old Milestone Date is before the minimum date for the chart
        '(NOT SURE THIS EVER GETS ACTIONED DUE TO dtmMinDate not being populated correctly...
        If varStoneData(intGenericCounter, 6) > "" And varStoneData(intGenericCounter, 6) < dtmMinDate And varStoneData(intGenericCounter, 6) < varStoneData(intGenericCounter, 2) Then
        
            
            intEndPoint = intColumnLeft + sngDistanceIn
            dtmMilestoneDate = dtmCurrentDate - intDaysBack
            Call DateToPosition(dtmMilestoneDate)
            intMilestoneDay = 3
            sngProportionOfMonth = (intMilestoneDay / intDaysMonth)
            sngDistanceIn2 = (intColumnWidth * sngProportionOfMonth) - (intMilestoneSize + 1) / 2
            intColour = 12632256
        
            'Insert the old milestone
            If varStoneData(intGenericCounter, 2) > dtmMinDate Then Call AddMilestone(intColumnLeft, lngRowTop, intMilestoneSize, intMilestoneSize, intColour, msoShapeLeftArrow)
            intStartPoint = intColumnLeft + sngDistanceIn2 + intMilestoneSize
            
            'Calculate the required start and end points for the slippage arrow
            intDistance = intEndPoint - intStartPoint
            intStartPoint = intStartPoint + intMilestoneSize * 0.5
            intEndPoint = intEndPoint - intMilestoneSize * 0.5
            
            'Insert the slippage arrow
            ActiveSheet.Shapes.AddLine(intStartPoint, lngRowTop + intMilestoneSize / 2, intEndPoint, lngRowTop + intMilestoneSize / 2).Select
            With Selection
                .ShapeRange.Name = intGenericCounter & "." & intShapeCount
                .ShapeRange.Line.Weight = 0.01
                .ShapeRange.Line.DashStyle = msoLineSquareDot
                .ShapeRange.Line.Style = msoLineSingle
                .ShapeRange.Line.Transparency = 0#
                .ShapeRange.Line.Visible = msoTrue
                .ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)               'Black arrow
                .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)         'White background
                .ShapeRange.Line.BeginArrowheadLength = msoArrowheadNarrow
                .ShapeRange.Line.BeginArrowheadWidth = msoArrowheadWidthMedium
                .ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone
                .ShapeRange.Line.EndArrowheadLength = msoArrowheadLengthMedium
                .ShapeRange.Line.EndArrowheadWidth = msoArrowheadWidthMedium
                .ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone
                .Placement = xlFreeFloating
            End With
            varShapeArray(intShapeCount) = Selection.Name
            intShapeCount = intShapeCount + 1
            
            'Add an arrow head shape manually to avoid sizing issues when pasting to word
            If varStoneData(intGenericCounter, 2) > dtmMinDate Then Call AddMilestone(intEndPoint - intMilestoneSize * 0.3, lngRowTop + intMilestoneSize * 0.25, intMilestoneSize / 2, intMilestoneSize / 2, RGB(100, 10, 10), msoShapeIsoscelesTriangle)
            Selection.ShapeRange.IncrementRotation 90#
            
            ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, intColumnLeft + intMilestoneSize + intMilestoneSize * 0.2, lngRowTop + intMilestoneSize * 0.1, 98.25, 21#).Select
                With Selection
                    .Characters.Text = "BL " & Day(varStoneData(intGenericCounter, 6)) & "/" & Month(varStoneData(intGenericCounter, 6)) & "/" & Year(varStoneData(intGenericCounter, 6))
                    .Font.Color = RGB(200, 200, 200)
                    .Font.Size = 1 * intMilestoneSize
                    .Font.FontStyle = "Bold"
                    .ShapeRange.Fill.Visible = msoFalse
                    .ShapeRange.Line.Visible = msoFalse
                    .AutoSize = True
                    .ShapeRange.TextFrame.MarginLeft = 0#
                    .ShapeRange.TextFrame.MarginRight = 0#
                    .ShapeRange.TextFrame.MarginTop = 0#
                    .ShapeRange.TextFrame.MarginBottom = 0#
                    .Placement = xlFreeFloating
                    .Name = intGenericCounter & "." & intShapeCount
                End With
            varShapeArray(intShapeCount) = Selection.Name
            intShapeCount = intShapeCount + 1
        End If
    
    'STEP 6: If milestone data indicates any special parameters (Complete/New/Deleted etc)then insert
    '        appropriate visual indicator
    '------------------------------------------------------------------------------------------------
    'Since milestone date may have been changed by Step 5 (adding old milestone), set dtmMilestoneDate back to the right item
    dtmMilestoneDate = varStoneData(intGenericCounter, 2)
    Call DateToPosition(dtmMilestoneDate)
    
    'Check the array data to see if any special parameters have been applied
    If blnUseColours = True Then
    
        'Select case and ensure Tick Colour passed in
        Select Case varStoneData(intGenericCounter, 9)
                Case "Complete"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop - 0.2 * intMilestoneSize, "ü", 10, intMilestoneSize + 0.2 * intMilestoneSize)
                Case "Deleted"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop - 0.2 * intMilestoneSize, "û", 1, intMilestoneSize + 0.6 * intMilestoneSize)
                Case "New"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop, "«", 11, intMilestoneSize + intMilestoneSize / 5)
                Case "Unconfirmed"
                    Call AddTick(intColumnLeft + sngDistanceIn - intMilestoneSize, lngRowTop - 0.3 * intMilestoneSize, "F", 0, intMilestoneSize + 0.6 * intMilestoneSize)
                Case Else
        End Select
    
    Else
        
        'Select case and ensure Tick Colour passed in AS BLACK
        Select Case varStoneData(intGenericCounter, 9)
                Case "Complete"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop - 0.2 * intMilestoneSize, "ü", 1, intMilestoneSize + 0.2 * intMilestoneSize)
                Case "Deleted"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop - 0.2 * intMilestoneSize, "û", 1, intMilestoneSize + 0.6 * intMilestoneSize)
                Case "New"
                    Call AddTick(intColumnLeft + sngDistanceIn, lngRowTop, "«", 11, intMilestoneSize + intMilestoneSize / 5)
                Case "Unconfirmed"
                    Call AddTick(intColumnLeft + sngDistanceIn - intMilestoneSize, lngRowTop - 0.3 * intMilestoneSize, "F", 1, intMilestoneSize + 0.6 * intMilestoneSize)
                Case Else
        End Select
    
    End If
        
        
    'STEP 7: Group all shapes for the current milestone set into a single object
    '---------------------------------------------------------------------------
    'This code to be revised. Messy Handling of "tick" objects
    If varStoneData(intGenericCounter, 2) > dtmMinDate Then
        
        ActiveSheet.Shapes.Range(Array(varShapeArray(0))).Select
        Selection.Name = "Collection" & intGenericCounter
        intShapeGroupingIndex = 1
    
    End If
    
    'Check to see if blnTickTrue
    If blnTickTrue = False Then
        Do While intShapeGroupingIndex < intShapeCount
            ActiveSheet.Shapes.Range(Array("Collection" & intGenericCounter, varShapeArray(intShapeGroupingIndex))).Select
            Selection.ShapeRange.Group.Select
            Selection.Placement = xlFreeFloating
            Selection.Name = "Collection" & intGenericCounter
            intShapeGroupingIndex = intShapeGroupingIndex + 1
        Loop
        'Load position array with position values of group
        varPositionArray(intGenericCounter, 0) = Selection.Top
        varPositionArray(intGenericCounter, 1) = Selection.Left
        varPositionArray(intGenericCounter, 2) = Selection.Height
        varPositionArray(intGenericCounter, 3) = Selection.Width
        varPositionArray(intGenericCounter, 4) = varStoneData(intGenericCounter, 0)
    Else
        Do While intShapeGroupingIndex < intShapeCount - 1
            ActiveSheet.Shapes.Range(Array("Collection" & intGenericCounter, varShapeArray(intShapeGroupingIndex))).Select
            Selection.ShapeRange.Group.Select
            Selection.Placement = xlFreeFloating
            Selection.Name = "Collection" & intGenericCounter
            intShapeGroupingIndex = intShapeGroupingIndex + 1
        Loop
        'Load position array with position values of group
        varPositionArray(intGenericCounter, 0) = Selection.Top
        varPositionArray(intGenericCounter, 1) = Selection.Left
        varPositionArray(intGenericCounter, 2) = Selection.Height
        varPositionArray(intGenericCounter, 3) = Selection.Width
        varPositionArray(intGenericCounter, 4) = varStoneData(intGenericCounter, 0)
        ActiveSheet.Shapes.Range(Array("Collection" & intGenericCounter, varShapeArray(intShapeGroupingIndex))).Select
        Selection.ShapeRange.Group.Select
        Selection.Placement = xlFreeFloating
        Selection.Name = "Collection" & intGenericCounter
    End If
    
    'STEP 8: Loop through each previous milestone in the position array and test for overlap
    '-------------------------------------------------------------------------------------
    If blnNewTask = False And intGenericCounter > 0 And varStoneData(intGenericCounter, 2) > dtmMinDate Then
        intOverlapIndex = intGenericCounter - 1
        Do While intOverlapIndex > -1 And varPositionArray(intOverlapIndex, 4) = varPositionArray(intOverlapIndex + 1, 4)
                blnOverlapB = False                    'Reset overlap indicators
                blnOverlapA = False                     'Reset overlap indicators
                'test for overlap top/bottom
                lngPreTop = varPositionArray(intOverlapIndex, 0)
                lngPreBottom = varPositionArray(intOverlapIndex, 0) + varPositionArray(intOverlapIndex, 2)
                lngNewTop = varPositionArray(intGenericCounter, 0)
                lngNewBottom = varPositionArray(intGenericCounter, 0) + varPositionArray(intGenericCounter, 2)
                If lngNewTop >= lngPreTop And lngNewTop <= lngPreBottom Then              'partial overlap of bottom of old shape
                    blnOverlapB = True
                ElseIf lngNewBottom >= lngPreTop And lngNewBottom <= lngPreBottom Then    'partial overlap of top of old shape
                    blnOverlapB = True
                ElseIf lngNewBottom <= lngPreBottom And lngNewTop >= lngPreTop Then       'full overlap of entire old shape
                    blnOverlapB = True
                ElseIf lngNewBottom >= lngPreBottom And lngNewTop <= lngPreTop Then       'pure subset overlap of old shape
                    blnOverlapB = True
                End If
                If blnOverlapB = True Then
                    'test for overlap left/right
                    intPreLeft = varPositionArray(intOverlapIndex, 1)
                    intPreRight = varPositionArray(intOverlapIndex, 1) + varPositionArray(intOverlapIndex, 3)
                    intNewLeft = varPositionArray(intGenericCounter, 1)
                    intNewRight = varPositionArray(intGenericCounter, 1) + varPositionArray(intGenericCounter, 3)
                    If intNewRight >= intPreLeft And intNewRight <= intPreRight Then      'partial overlap of left of old shape
                        blnOverlapA = True
                    ElseIf intNewLeft >= intPreLeft And intNewLeft <= intPreRight Then    'partial overlap of right of old shape
                        blnOverlapA = True
                    ElseIf intNewLeft <= intPreLeft And intNewRight >= intPreRight Then   'full overlap of entire old shape
                        blnOverlapA = True
                    ElseIf intNewLeft >= intPreLeft And intNewRight <= intPreRight Then   'pure subset overlap of old shape
                        blnOverlapA = True
                    End If
                    If blnOverlapA = True Then
                        Selection.Top = lngPreBottom + intMidPad
                        varPositionArray(intGenericCounter, 0) = Selection.Top
                        intOverlapIndex = intGenericCounter
                    End If
                    If varPositionArray(intGenericCounter, 0) + varPositionArray(intGenericCounter, 2) > lngMaxHeight Then
                            lngMaxHeight = varPositionArray(intGenericCounter, 2) + varPositionArray(intGenericCounter, 0)
                    End If
                End If
            intOverlapIndex = intOverlapIndex - 1
            If intOverlapIndex = -1 Then GoTo endmainloop
        Loop
    End If

endmainloop:

    'Increase the master counter
    intGenericCounter = intGenericCounter + 1

Loop

    Call testTimer("Chart Building (Stones Added)")
'"TIDYING UP PROCESS" - Some final actions to ensure the chart is cleaned up appropriately
'******************************************************************************************
wsChart.Range("a1").Select
With wsChart.Range("A1")
    .Value = strProjectName
    .Font.Size = 1
    .Font.Bold = True
    .HorizontalAlignment = xlRight
    .VerticalAlignment = xlCenter
End With

strMergeRange2 = ActiveCell.Offset(0, 0).Address & ":" & ActiveCell.Offset(0, intMonthsToInclude + 3).Address
Range(strMergeRange2).Merge


'Sheets("Chart").Rows(1).RowHeight = intMilestoneSize * 1.6 + 60
'Sheets("Chart").Rows(2).RowHeight = intMilestoneSize * 0.8 + 15

intCounter = 1
Range("b2").Select
intChartRows = Range("a2").CurrentRegion.Rows.Count


'STEP 1: Increase the size of the bottom row
'-------------------------------------------
If lngMaxHeight > 0 Then
    rngShapeTargetRange.Select
        Selection.RowHeight = lngMaxHeight - Selection.Top + 4
    End If

     
'STEP 2: Add the "today" line
'----------------------------

Dim CellDate As Date
    CellDate = Sheets("Workplan").Range("N9").Value

lngLineLength = Range("A2").CurrentRegion.Top + Range("A2").CurrentRegion.Height

Call DateToPosition(CellDate)
intTodayDay = Day(CellDate)
sngProportion = (intTodayDay / intDaysMonth)
sngTodayDistIn = (intColumnWidth * sngProportion)
If lngLineLength < 150000 Then
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 5#
        '.ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
        .ShapeRange.ZOrder msoSendToBack
    End With
Else
    ' We lines max out somewhere around 150,000 line length so attempt to draw 2.
    ' If we start hitting 300,000 may need to come up with a different solution
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, 150000).Select
    With Selection
        .ShapeRange.Line.Weight = 5#
        '.ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
    End With
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, 150000, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 5#
        '.ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(255, 0, 0)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
        .ShapeRange.ZOrder msoSendToBack
    End With
End If

Worksheets("Chart").Range("A2").Select
    Call testTimer("Chart Building (Tidy inc Today Line)")
' Set up new display features
'Call ChartDisplay.FixRowHeighLabels

'STEP 2.1: Add the "Day 1" line
'----------------------------

Dim Day1Date As Date
    Day1Date = Sheets("Workplan").Range("C2").Value

lngLineLength = Range("A2").CurrentRegion.Top + Range("A2").CurrentRegion.Height

Call DateToPosition(Day1Date)
intDay1Day = Day(Day1Date)
sngProportion = (intDay1Day / intDaysMonth)
sngTodayDistIn = (intColumnWidth * sngProportion)
If lngLineLength < 150000 Then
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 5#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
       .ShapeRange.ZOrder msoSendToBack
    End With
Else
    ' We lines max out somewhere around 150,000 line length so attempt to draw 2.
    ' If we start hitting 300,000 may need to come up with a different solution
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, 150000).Select
    With Selection
        .ShapeRange.Line.Weight = 5#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
    End With
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, 150000, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 5#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
        .ShapeRange.ZOrder msoSendToBack
    End With
End If

Worksheets("Chart").Range("A2").Select
    Call testTimer("Chart Building (Tidy inc Day 1 Line)")
' Set up new display features
'Call ChartDisplay.FixRowHeighLabels

'STEP 2.1: Add the "Day 100" line
'----------------------------

Dim Day100Date As Date
    Day100Date = Sheets("Workplan").Range("C4").Value

lngLineLength = Range("A2").CurrentRegion.Top + Range("A2").CurrentRegion.Height

Call DateToPosition(Day100Date)
intDay100Day = Day(Day100Date)
sngProportion = (intDay100Day / intDaysMonth)
sngTodayDistIn = (intColumnWidth * sngProportion)
If lngLineLength < 150000 Then
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 10#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
        .ShapeRange.ZOrder msoSendToBack
    End With
Else
    ' We lines max out somewhere around 150,000 line length so attempt to draw 2.
    ' If we start hitting 300,000 may need to come up with a different solution
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, Range("A2").CurrentRegion.Top, intColumnLeft + sngTodayDistIn, 150000).Select
    With Selection
        .ShapeRange.Line.Weight = 5#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
    End With
    ActiveSheet.Shapes.AddLine(intColumnLeft + sngTodayDistIn, 150000, intColumnLeft + sngTodayDistIn, lngLineLength).Select
        With Selection
        .ShapeRange.Line.Weight = 5#
        .ShapeRange.Line.DashStyle = msoLineDash
        If blnUseColours = True Then
            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
        Else
            .ShapeRange.Line.ForeColor.RGB = RGB(125, 125, 125)
        End If
        .ShapeRange.ZOrder msoSendToBack
    End With
End If

Worksheets("Chart").Range("A2").Select
    Call testTimer("Chart Building (Tidy inc Day 100 Line)")
' Set up new display features
'Call ChartDisplay.FixRowHeighLabels

Call ChartDisplay.ColourcodeMileStones

    Call testTimer("Chart Building (ColourCode Milestones Done)")
Call MergeCells(intMonthsToInclude)

    Call testTimer("Chart Building (MergeCells done)")
    
Application.DisplayAlerts = True
'STEP 4: Add the Project Name from the User preferences to A1, then merge/centre Column A
'----------------------------------------------------------------------------------------


'STEP 5: Add a Key
'------------------------------------------------------------
'NEED ADD KEY PROCESS HERE

Worksheets("Preferences").Shapes("Picture 66").Copy
Worksheets("Chart").Paste Range("A1")

'STEP 6: Configure Page Set Up
'-----------------------------
Application.DisplayAlerts = True

Sheets("Chart").Select
Dim Lastrow As Integer
Lastrow = Range("A65536").End(xlUp).Row
Range("A3").CurrentRegion.Select
ActiveSheet.PageSetup.PrintArea = Selection.Address

With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$2"
    .PrintTitleColumns = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = "HIGHLY CONFIDENTIAL"
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.1)
    .RightMargin = Application.InchesToPoints(0.1)
    .TopMargin = Application.InchesToPoints(0.5)
    .BottomMargin = Application.InchesToPoints(0.3)
    .HeaderMargin = Application.InchesToPoints(0.15)
    .FooterMargin = Application.InchesToPoints(0.2)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = True
    .CenterVertically = False
    .Orientation = xlLandscape
    .Draft = False
    .PaperSize = xlPaperA4
    .FirstPageNumber = xlAutomatic
    .Order = xlDownThenOver
    .BlackAndWhite = False
    .PrintErrors = xlPrintErrorsDisplayed
    .OddAndEvenPagesHeaderFooter = False
    .DifferentFirstPageHeaderFooter = False
    .ScaleWithDocHeaderFooter = False
    .AlignMarginsHeaderFooter = False
    .EvenPage.LeftHeader.Text = ""
    .EvenPage.CenterHeader.Text = ""
    .EvenPage.RightHeader.Text = ""
    .EvenPage.LeftFooter.Text = ""
    .EvenPage.CenterFooter.Text = ""
    .EvenPage.RightFooter.Text = ""
    .FirstPage.LeftHeader.Text = ""
    .FirstPage.CenterHeader.Text = ""
    .FirstPage.RightHeader.Text = ""
    .FirstPage.LeftFooter.Text = ""
    .FirstPage.CenterFooter.Text = ""
    .FirstPage.RightFooter.Text = ""
    .Orientation = xlLandscape
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = False
    
Range("A1").Select
    
End With

'STEP 7: Copy and paste the original task list back to the first column and replace the data that was changed
'during the process.
'------------------------------------------------------------------------------------------------------------
Sheets("Plan").Select
Range("a4", Range("a4").End(xlDown)).Select
Selection.Cut

Range("b4").Select
ActiveSheet.Paste

If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If

Sheets("Chart").Select


'STEP 8: Export the chart if required
'------------------------------------------------------------------------------------------------------------

If Sheets("Workplan").Range("J9") = True Then

'Call PrintPDF

Else
Sheets("Chart").Select
GoTo GenerateChart_Exit

End If

GenerateChart_Exit:
   
    'Release Public variables
    intDaysMonth = 0
    intColumnLeft = 0
    intColumnWidth = 0
    lngRowTop = 0
    intRowHeight = 0
    intGenericCounter = 0
    intShapeCount = 0
    blnTickTrue = 0
    blnOrder = 0
    Application.ScreenUpdating = True
    
    Call testTimer("Chart Done")
    Exit Sub


End Sub

Public Sub AddMilestone(shapeleft As Integer, shapetop As Long, shapeheight As Integer, shapewidth As Integer, shapecolor As Long, shapetype As MsoAutoShapeType, Optional RAGLetter As String)
'PURPOSE: Adds a shape to the chart using arguments passed in.
'CALLED FROM: GenerateChart procedure

'Add shape based on input parameters and select it
ActiveSheet.Shapes.AddShape(shapetype, shapeleft, shapetop, shapeheight, shapewidth).Select

'Format the shape
With Selection
    .ShapeRange.Line.Visible = msoTrue
    .Name = intGenericCounter & "." & intShapeCount
    .ShapeRange.TextFrame.MarginLeft = 0#
    .ShapeRange.TextFrame.MarginRight = 0#
    .ShapeRange.TextFrame.MarginTop = 0#
    .ShapeRange.TextFrame.MarginBottom = 0#
    .ShapeRange.TextFrame.HorizontalAlignment = xlHAlignCenter
    .ShapeRange.TextFrame.VerticalAlignment = xlVAlignCenter
    If RAGLetter <> "" Then
        .ShapeRange.TextFrame.Characters.Text = RAGLetter
        .ShapeRange.TextFrame.Characters.Font.Bold = True
        .ShapeRange.TextFrame.Characters.Font.Size = 28
    End If
    .ShapeRange.Fill.Visible = msoTrue
    .ShapeRange.Fill.ForeColor.RGB = shapecolor
    .Placement = xlFreeFloating
End With
       
'Send to back as required
If blnOrder = False Then Selection.ShapeRange.ZOrder msoSendToBack
             
'Populate the shape count array which has been declared public
varShapeArray(intShapeCount) = Selection.Name
        intShapeCount = intShapeCount + 1

End Sub

Sub AddTick(tickleft As Integer, ticktop As Long, ticktype As String, tickcolor As Integer, ticksize As Integer)
'PURPOSE: Adds a "tick" symbol where a special indicator is required on a milestone
'CALLED FROM: Generate Chart Procedure

'Add a text box to the sheet based on input parameters and select it
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, tickleft, ticktop, 1, 1).Select

'Add text to the selected item
Selection.Characters.Text = ticktype
With Selection.Characters(Start:=1, Length:=1).Font
    .Name = "Wingdings"
    .FontStyle = "Bold"
    .Size = ticksize
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = tickcolor
End With

'Format the selected item
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Selection.Placement = xlFreeFloating
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .Orientation = xlHorizontal
    .AutoSize = True
    .Name = intGenericCounter & "." & intShapeCount
End With

'Place the defined name of the shape into the Shape Array and update counters
varShapeArray(intShapeCount) = Selection.Name
intShapeCount = intShapeCount + 1
blnTickTrue = True

End Sub

Sub DateToPosition(datein As Date)
'PURPOSE: Converts a date passed in so it points to the first of the month in which that date occurs
'         then looks through Row 2 (which consists of dates based on 1st of Month) in order to find
'         date passed in. Once found, the cell containing the date is selected

On Error Resume Next

Dim foundrange As Range
Dim datefind As Date

'Set recieved date to first of month
datefind = DateSerial(Val(Year(datein)), Val(Month(datein)), 1)

'search for date
Set foundrange = Range("2:2").Find(datefind)
    If foundrange Is Nothing Then
        'MsgBox "DATE NOT FOUND - Please enter a valid date"
    Else
        foundrange.Select
    End If

'Set public variables with the right values
intColumnLeft = Selection.Left
intColumnWidth = Selection.Width

'Call days in month function to determine how many days in the month that has been found
Call daysinmonth(Month(datefind))

End Sub

Public Function daysinmonth(ByVal iMonthNum As Integer)
'PURPOSE: Determines how many days there are in the months of the year NB: Ignores leap years
    Select Case iMonthNum
        Case 1, 3, 5, 7, 8, 10, 12
            daysinmonth = 31
        Case 2
            daysinmonth = 28
        Case 4, 6, 9, 11
            daysinmonth = 30
    End Select

'Set public variable to the number of days in the month
intDaysMonth = daysinmonth

End Function

Public Sub MergeCells(ByVal intMonthsToInclude As Integer)

'STEP 3: Remerge the cells
'-------------------------
Dim intCounter As Integer
Dim intChartRows As Integer
Dim lngMergeCellHeight As Long
Dim strRowRef1 As String
Dim strRowRef2 As String
Dim strMergeRange1 As String
Dim intMergeCounter As Integer

intCounter = 1
intChartRows = Range("d2").CurrentRegion.Rows.Count - 1
Range("c2").Select
lngMergeCellHeight = 0
Application.DisplayAlerts = False
Do While intCounter < intChartRows
    If Left(ActiveCell.Offset(intCounter, 0), Len(ActiveCell.Offset(intCounter, 0))) = Left(ActiveCell.Offset(intCounter + lngMergeCellHeight, 0), Len(ActiveCell.Offset(intCounter, 0))) Then
        Do While Left(ActiveCell.Offset(intCounter, 0), Len(ActiveCell.Offset(intCounter, 0))) = Left(ActiveCell.Offset(intCounter + lngMergeCellHeight, 0), Len(ActiveCell.Offset(intCounter, 0)))
           lngMergeCellHeight = lngMergeCellHeight + 1
        Loop
        For intMergeCounter = 0 To intMonthsToInclude + 1
        strRowRef1 = ActiveCell.Offset(intCounter, intMergeCounter).Address
        strRowRef2 = ActiveCell.Offset(intCounter + lngMergeCellHeight - 1, intMergeCounter).Address
        strMergeRange1 = strRowRef1 & ":" & strRowRef2

        ' Erroring Here
        If Not strRowRef1 = strRowRef2 Then
            Range(strMergeRange1).Merge
        End If
        Next

    intCounter = intCounter + lngMergeCellHeight - 1
    End If
    lngMergeCellHeight = 0
    intCounter = intCounter + 1
Loop

ActiveSheet.Shapes.SelectAll
Selection.Placement = xlMove

Application.DisplayAlerts = True



End Sub

Open in new window

Philippa HorneAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jamie GarrochPowerPoint Consultant & DeveloperCommented:
This code appears to run within an Excel Workbook. Correct? It does not make reference to any external file(s) but it does reference objects within the workbook such as line 18 where it refers to a sheet named "Plan", cell B3 and line 168 where it refers to another sheet named "Preferences" with multiple cell references etc.

So when you say your employer wants to "change to a different project file within the SharePoint location", what is the "project file"? Is it the file which contains the code above. If so, maybe all you need to do is copy the code from above from the current workbook module to a new module in the new workbook (assuming it has the same sheet/range data structure).
0
Philippa HorneAuthor Commented:
Morning Jamie, sorry for the delay, yes runs within an Excel workbook.  The excel book summarises the data from the sharepoint file probably only way to proceed would be to share the files with you.  Just checking with my employer first as sensitive data may be contained in the files that needs to be removed.  Thanks so much for trying

Pippa
0
Philippa HorneAuthor Commented:
Ooh I found this code, which looks like it pulls the data but not sure how to change the sharepoint source

Sub UpdateIP()
'
' Unfilter and sort
Call Unfilter
Call EverythingOff

    ActiveWorkbook.Worksheets("Workplan").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Workplan").AutoFilter.Sort.SortFields.Add Key:= _
        Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Workplan").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' Delete MU pasted in values in column D of workplan
Worksheets("Workplan").Range("D12:D8000").ClearContents

' UpdateIP Macro
ActiveWorkbook.RefreshAll

Sheets("From SharePoint").Activate

With Range("F:G")
  .Replace Chr$(13), vbNullString
  .Replace Chr$(30), vbNullString
  .Replace Chr$(126), vbNullString
End With

ActiveWorkbook.Sheets("Workplan").Activate

    var1 = 13
    var2 = Range("C6").Value

    Rows("13:13").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete

    Rows("12:12").Select
    Selection.Copy
    Rows(var1 & ":" & var2 + 11).Select
    ActiveSheet.Paste
    
    With Rows(var1 & ":" & var2 + 11).Select
        Selection.Copy
        Selection.PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
   
     
ActiveWorkbook.Sheets("Workplan").Activate
Range("a1").Select

Call EverythingOn
   
End Sub

Sub ExportSP()

    var3 = 3
    var4 = Sheets("To Convert").Range("C7").Value

Sheets("To SharePoint").Activate

    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete

    Rows("2:2").Select
    Selection.Copy
    Rows(var3 & ":" & var4 + 1).Select
    ActiveSheet.Paste
    Rows(var3 & ":" & var4 + 1).Select
    Selection.Copy
    Selection.PasteSpecial xlPasteValues

    Application.CutCopyMode = False
   
Range("a1").Select

End Sub

Open in new window

0
Jamie GarrochPowerPoint Consultant & DeveloperCommented:
This code (that is designed to run in the Excel VBE) appears to assume that there are already sheets available in the workbook as these lines elude to:

Sheets("From SharePoint").Activate
Sheets("To SharePoint").Activate

Open in new window


The code itself does not directly interact with a Sharepoint server. But I don't see any reason why you could not use the standard UNC path format to specify the URL of a Sharepoint file from within VBA. Something like this very basic call:

Application.Workbooks.Open "http://myHost/mySite/mySheet.xlsx"

Open in new window


...assuming user permissions are all valid etc.
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft SharePoint

From novice to tech pro — start learning today.