taking too long to load2

hi,

Please help me see why is my code takes very long to execute?
i have to remove alot of codes coz its unable to submit.

Option Explicit
Dim i As Integer
Dim sheetname As String
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim FSOobj As Object
Dim actionstop As S
    Set WDApp = GetObject(, "Word.Application")
    WDApp.Visible = True
    
    Set WDDoc = WDApp.ActiveDocument
    sheetname = ActiveSheet.Name
    
    Application.Worksheets(sheetname).Activate
    actionstop = ""
    newtemplatecheck
    
   
    
    If actionstop = "stop" Then Exit Sub
 
    Dim reportbupath As String
    Dim reportname As String
    Dim fso As Object

    Dim doc As String
    Dim Reportbufolder As String
    Dim vbf As String
    Dim vb As String
    Dim toreportftppath As String
    Dim reportpdf As String

    
    formatDDMMYY = Format(Date, "DDMMYY")
    formatyyyymmdd = Format(Date, "YYYY-MM-DD")
    doc = ".doc"
    reportpdf = WDDoc.FormFields("NRIC").Result & "_" & formatDDMMYY & ".pdf"
    reportname = WDDoc.FormFields("NRIC").Result & "_" & formatDDMMYY & doc
    Reportbufolder = Sheets("DATA").Cells(1, 2).Value & Format(Date, "YYYY") & "\" & formatyyyymmdd & "\"

    


    
    If Dir(newPath, vbDirectory) = "" Then
        MkDir newPath
    End If

    Set fso = CreateObject("Scripting.FilesystemObject")
    
    If fso.FolderExists(Reportbufolder) = False Then
    vbf = MsgBox("Folder not created. Created " & formatyyyymmdd & " folder?", vbOKCancel)
    
    If vbf = vbOK Then
    fso.CreateFolder (Reportbufolder)
    ElseIf vbf = vbCancel Then
    Exit Sub
    End If
    
    End If

    If fso.FileExists(reportbupath) = False Then
    
    WDDoc.SaveAs reportbupath
    
    WDDoc.ExportAsFixedFormat OutputFileName:= _
    Reportbufolder & WDDoc.FormFields("NRIC").Result & "_" & formatDDMMYY & ".pdf", ExportFormat:= _
    wdExportFormatPDF
    
    
    ElseIf fso.FileExists(reportbupath) = True Then
        vb = MsgBox("Copy already present in server. Do you want to continue overwriting the file?", vbOKCancel)
        
        If vb = vbOK Then
            WDDoc.SaveAs reportbupath
            WDDoc.ExportAsFixedFormat OutputFileName:= _
            Reportbufolder & WDDoc.FormFields("NRIC").Result & "_" & formatDDMMYY & ".pdf",

            Exit Sub
        End If
    
    End If
    
    Dim ImageFromFTPPath As String
    Dim Imagetobupath As String
    Dim count As Integer
    ImageFromFTPPath = "H:\IN\" 
    Imagetobupath = "Z:\SGH Diabetes Centre\ "\"      
    
    Set FSOobj = CreateObject("Scripting.FilesystemObject")
    
        If FSOobj.FolderExists(Imagetobupath) = False Then
        vbf = MsgBox("Folder not created. Created " & formatyyyymmdd & " folder?", vbOKCancel)
        If vbf = vbOK Then
        FSOobj.CreateFolder (Imagetobupath)
        ElseIf vb = vbCancel Then
    Exit Sub
    
    End If
    End If
    
    If fso.FileExists(toreportftppath & reportpdf) = False Then
        'WDDoc.SaveAs toreportftppath & reportname
        WDDoc.Activate


        
    ElseIf fso.FileExists(toreportftppath & reportpdf) = True Then
        vb = MsgBox("Copy already present in FTP. Do you want to continue overwriting the file?", vbOKCancel)
        
        If vb = vbOK Then
            'WDDoc.SaveAs toreportftppath & reportname
            WDDoc.Activate
            
            WDDoc.ExportAsFixedFormat OutputFileName:= _
            toreportftppath & reportpdf, ExportFormat:= _
            wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        
            ElseIf vb = vbCancel Then
            Sheets(sheetname).Select
            Exit Sub
        End If
    End If
   
    
    WDDoc.Close
    WDApp.Quit
    


    Set FSOobj = Nothing
    

    Dim getfolder As Object
    Dim objFile As Object
    Dim ID As String
    Dim reportID As String
    
    reportID = ActiveSheet.Cells(i, 4).Value
    checkTime reportID, ImageFromFTPPath
        Set fso = CreateObject("scripting.filesystemobject")
        Set objgetFolder = fso.getfolder(ImageFromFTPPath)
    
        count = 0
    
    
    If Len(reportID) > 9 Then
        For Each objFile In objgetFolder.Files  
            If Left(objFile.Name, Len(reportID)) = reportID Then
                If fso.FileExists(Imagetobupath & objFile.Name) = False Then
                    fso.MoveFile Source:=objFile, Destination:=Imagetobupath
                    count = count + 1
                End If
            End If
        Next
    Else
        For Each objFile In objgetFolder.Files
            If Left(objFile.Name, 9) = reportID Then
                If fso.FileExists(Imagetobupath & objFile.Name) = False Then
                    fso.MoveFile Source:=objFile, Destination:=Imagetobupath
                    count = count + 1
                End If
            End If
        Next
    End If
    If count = 0 Then
        MsgBox "."
    End If
    
    
    
    
    
    
    MsgBox ID & "Total " & count &"Process finished"
    count = 0



MsgBox "Report Saved"
End Sub

Sub checkTime(reportID As String, ImageFromFTPPath As String)
    Dim dte As Date
    Dim onlyTime As Date
    Dim fullDateTime As String
    Dim imageCreatedTime As Date
    Dim timeDifference As Double
    Dim oFS As Object

    imageCreatedTime = Format(oFS.GetFile(fileName).DateCreated, "HH:MM")
    Sheets("DATA").Cells(6, 2).Value = imageCreatedTime
    Sheets("DATA").Cells(7, 2).Value = TimeDiff(onlyTime, imageCreatedTime) / 60
    Set oFS = Nothing
End Sub

Function TimeDiff(StartTime As Date, StopTime As Date)

    TimeDiff = Abs(StopTime - StartTime) * 86400
End Function


Sub newtemplatecheck()

    Set WDApp = GetObject(, "Word.Application")
    WDApp.Visible = True
    
    Set WDDoc = WDApp.ActiveDocument
    sheetname = ActiveSheet.Name
    Application.ScreenUpdating = False
    actioncount = 0
    
    If WDDoc.FormFields("NoRetinopathyRE").CheckBox.Value = False And WDDoc.FormFields("MinimalRE").CheckBox.Value = False And _
    WDDoc.FormFields("MildRE").CheckBox.Value = False And WDDoc.FormFields("ModerateRE").CheckBox.Value = False And _

    
        If WDDoc.FormFields("NoRetinopathyLE").CheckBox.Value = False And WDDoc.FormFields("MinimalLE").CheckBox.Value = False And _

        WDDoc.FormFields("PActiveLE").CheckBox.Value = False Then
    
            If WDDoc.FormFields("GlacomaSuspectRE").CheckBox.Value = False And WDDoc.FormFields("GlacomaSuspectLE").CheckBox.Value = False Then
            

                        If WDDoc.FormFields("UngradableRE").CheckBox.Value = False And WDDoc.FormFields("UngradableLE").CheckBox.Value = False Then
                        
                            If WDDoc.FormFields("Others").Result = "N.A." And WDDoc.FormFields("OthersRE").CheckBox.Value = False And _
                            WDDoc.FormFields("OthersLE").CheckBox.Value = False Then
    
                                If WDDoc.FormFields("MainFinding").Result = "Please Select" And WDDoc.FormFields("Comments").Result = "" And _
                                WDDoc.FormFields("ReScreen6Months").CheckBox.Value = False Then
    
                                    If WDDoc.FormFields("Immediate").CheckBox.Value = False And WDDoc.FormFields("Week1").CheckBox.Value = False And _
                                    WDDoc.FormFields("Month1").CheckBox.Value = False And WDDoc.FormFields("Months3").CheckBox.Value = False And _
                                    WDDoc.FormFields("Months6").CheckBox.Value = False Then
                                        
                                        actioncount = actioncount + 1
                                    
                                    End If
          
                End If
            End If
        End If
    End If
    
    If actioncount > 0 Then
        actionstop = "stop"
        MsgBox "The form has not been edited!!!", vbExclamation, "Form validation"
        Exit Sub
    End If
    
    
    actioncount = 0
    If WDDoc.FormFields("Immediate").CheckBox.Value = True Then actioncount = actioncount + 1
    If WDDoc.FormFields("Week1").CheckBox.Value = True Then actioncount = actioncount + 1


    

    If WDDoc.FormFields("MainFinding").Result = "Please Select" Then
        actionstop = "stop"
        MsgBox "Please check the Main Diagnosis, it is not selected!!!", vbExclamation, "Form validation"
        Exit Sub
    End If
    
 
    If WDDoc.FormFields("Others").Result <> "N.A" Then
        If WDDoc.FormFields("OthersRE").CheckBox.Value = False And WDDoc.FormFields("OthersLE").CheckBox.Value = False Then
            actionstop = "stop"
            MsgBox "Please check the Others Ocular finding, it is not selected!!!", vbExclamation, "Form validation"
            Exit Sub
        End If
    End If

    i = Sheets(sheetname).Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row ' Count to the last row
    
    Cells(i, 1).Value = Sheets(sheetname).Cells(1, 4).Value
    Cells(i, 2).Value = Format(Date, "dd-mmm-yy")
  

    Dim rowColor As Integer
    For rowColor = 0 To 4
        If Cells(i, (48 + rowColor)).Value = "True" Then
            ActiveSheet.Range("a" & i, "az" & i).Select
            With Selection.Font
                .Color = -4165632
                .TintAndShade = 0
            End With
            Exit For
        End If
    Next

With WDDoc
'

    .FormFields("MinimalRE1").CheckBox.Value = .FormFields("MinimalRE").CheckBox.Value
    .FormFields("MildRE1").CheckBox.Value = .FormFields("MildRE").CheckBox.Value

    End With
    actioncount = 0
    
    

End Sub