各位老师，我的代码为什么运行的时候越来越慢？

jiaodaoniu

各位老师，能否帮忙看下这个文件。
文件是根据每个人生成每个人的成绩单，把看板sheet 里的 图片组合 复制成一个picture，然后发邮件给每个人。
运行后到后面会越变越慢，这是怎么回事？


Sub 发送成绩()
   
    Application.ScreenUpdating = False
   
    Path = ThisWorkbook.Path
   
    Dim a, b, c, d As Integer
    Dim 名字, 邮箱 As String
    Dim shp As Shape
   
    For a = 1 To 45
   
    Sheets("分数看板").Select
   
    名字 = Sheets("学生信息表").Range("E" & a + 1)
    邮箱 = Sheets("学生信息表").Range("L" & a + 1)

    'ActiveSheet.PivotTables("数据透视表1").PivotFields("姓名").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("姓名").CurrentPage = 名字
   
    Sheets("看板").Select
   

   
    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Copy
    Range("B2").Select

LINE:
    On Error GoTo -1
    On Error GoTo LINE
    ActiveSheet.Pictures.Paste.Select

    Selection.name = 名字
   
    Sheets("看板").Copy
    ActiveWorkbook.SaveAs Filename:= _
        Path & "\" & 名字 & " 成绩.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
   
    ActiveSheet.Shapes.Range(Array("Group 1")).Select
    Selection.Delete
        
    ActiveWorkbook.Save
        
    Application.CutCopyMode = False
      
    Dim olApp As Object
    Dim olNameSpace As Object
    Dim olFolder As Object
    Dim olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(6)
    Set olMail = olApp.CreateItem(0)
               
    With olMail
        
        .Subject = 名字 & " 成绩"
        .To = 邮箱
        '.Htmlbody = RangetoHTML(rptrange)
        .Attachments.Add ActiveWorkbook.FullName
        .Send
        'SendKeys "%s", Wait:=True
    End With
        
    ActiveWorkbook.Close
   
    'Kill Path & "\" & 名字 & " 成绩.xlsx"
   
    'Sheets("看板").Select
   
    ActiveSheet.Shapes(名字).Select
    Selection.Delete
        
    Sheets("分数看板").Select
        
    Next a
         
    ActiveWorkbook.Save
   
    Application.ScreenUpdating = True
   
End Sub

jiaodaoniu

各位老师，帮忙看一下。