Excel not responding while running VBA

[stioks]

Hey guys. I have some issues with my VBA. It work fine, but rather slow and at some point my excel is not responding.
Here is my code. The issue appears while executing the code:


Workbooks("Sum").Activate
Dim formularng As Range
Set formularng = Range(Range("B2"), Range("B2").End(xlDown)).Offset(0, 1)
formularng.FormulaR1C1 = "=SUM(RC[1]:RC[150])"

Dim sFoundSt As String
Dim f As Object
Dim objFSO As Object
Dim Pathh As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Pathh = objFSO.GetFolder("G:\EA\8 Traffic Light\")

Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Workbooks.Open filename:="G:\EA\8 Traffic Light\Sum.xlsx"
Range("C2").Value = "X"
Workbooks("Clients List").Activate
    For Each C In Range("a2:a5")
        If C.Value <> "" Then 'Exit For
            path = "G:\EA\8 Traffic Light\Export\"
            Clientid = C.Value
            NameCl = C.Offset(0, 1).Value
            ITN = C.Offset(0, 2).Value
            tsID = C.Offset(0, 3).Value
            filename = Clientid & "*" & ".xl*"
            sFoundSt = Dir(path & Clientid & "*.xl*")
            
            If sFoundSt <> "" Then
                For Each f In Pathh.Files
                    If InStr(1, f.Name, Clientid, vbTextCompare) > 0 Then
                    Workbooks.Open (f)
                    End If
                
                    Dim WBs As Workbook
                    
                    
                        For Each WBs In Application.Workbooks
                            
                            If WBs.Name <> ThisWorkbook.Name And WBs.Name <> "Sum.xlsx" Then
                                
                                WBs.Activate                                
                                Range("A2:B746").Copy
                                Workbooks("Sum").Activate
                                Range("A2").Select
                                ActiveSheet.Paste
                               
                                WBs.Activate
                                Range("C2:C746").Copy
                                Workbooks("Sum").Activate
                                Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial (xlPasteValues)
                                Application.CutCopyMode = False
                                WBs.Close
                                                                                               
                            End If
                        Next WBs
                     
                     
                Next f
               
                Workbooks("Sum").Activate
                Dim formularng As Range
                Set formularng = Range(Range("B2"), Range("B2").End(xlDown)).Offset(0, 1)
                formularng.FormulaR1C1 = "=SUM(RC[1]:RC[150])"
                                           
                              
                Workbooks("Sum").Sheets(1).Copy
                Range(Range("C2"), Range("C2").End(xlDown)).Copy
                Range("C2").Select
                        Selection.PasteSpecial (xlPasteValues)
                        Range(Range("D2"), Range("D800").Offset(0, 200)).ClearContents
                Range("D2").Value = NameCl
                Range("E2").Value = ITN
                Range("F2").Value = tsID
                ActiveWorkbook.SaveAs filename:="G:\EA\For Traffic Light\" & Clientid & "_" & NameCl & ".xlsx"
                ActiveWorkbook.Close
                                    
                Workbooks("Sum").Close savechanges:=False
                
                
            Else
            MsgBox "Missing ID" & ": " & Clientid
            C.Select
            Exit Sub
            End If
             
                
        End If
    Next C
    
    
    MsgBox "Rdy"
    Application.ScreenUpdating = True
End Sub

[snb]

Remove all 'select' and 'activate'.
Avoid any copying.
Disable calculation automatically.

Do not use workbooks.open but Getobject(filename)