Sub PrintResourceCharts()
'It will automatically adjust the timescale to show all of the resource's activities
'Create Task Lists
Dim r As Resource
Application.DisplayAlerts = False
ViewApply Name:="Steria Task Lists"
For Each r In ActiveProject.Resources
    If r.Assignments.Count > 0 Then
        mystring = r.Name
            FilterEdit Name:="Steria Task Lists", TaskFilter:=True, Create:=True, _
            OverwriteExisting:=True, FieldName:="Resource Names", test:="Contains exactly", _
            Value:=mystring, ShowInMenu:=False, ShowSummaryTasks:=False
            FilterApply "Steria Task Lists"
            
            SetAutoFilter FieldName:="Resource Names", FilterType:=pjAutoFilterIn, Criteria1:=mystring
            SelectTaskColumn Column:="Resource Names", Additional:=10
            EditCopy
            On Error Resume Next
            AppActivate ("Microsoft excel")
            Set ExcelSheet = CreateObject("Excel.Application")
            ExcelSheet.Application.Visible = True
            Set xlWB = ExcelSheet.Workbooks.Open("D:\Task List Templates\Task List.xlsm")
            xlApp.Visible = True
        FileSaveAs Name:="D:\Task List Templates\Task Lists\" & mystring & ".xls", FormatID:="MSProject.XLS5", map:="Steria Task Lists"
        ActiveWorkbook.Close
    End If
Next r
MsgBox ("Individual Resource Sheets have been produced.")
    ViewApply Name:="Gantt Chart"
Application.DisplayAlerts = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'
'
Dim wbName
Application.DisplayAlerts = False
On Error Resume Next
    Range("A1").Select
    ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False
    wbName = Range("A2").Value
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:A").ColumnWidth = 14.43
    Columns("D:D").ColumnWidth = 34
    Columns("E:K").EntireColumn.AutoFit
    Columns("D:D").Select
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1").Select
    ChDir "D:\Task List Templates\Task Lists\"
    
    ActiveWorkbook.SaveAs Filename:="D:\Task List Templates\Task Lists\" & wbName & ".xls", FileFormat:=xlNormal, _
    Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    CreateBackup:=False
    
'    ActiveWorkbook.SaveAs Filename:="D:\Task List Templates\Task Lists\" & wbName & ".xls", FileFormat:=xlNormal
    Application.DisplayAlerts = True
    ActiveWorkbook.Close SaveChanges:=False
End Sub