PDA

View Full Version : Excel not responding while running VBA



stioks
09-29-2015, 03:01 AM
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
09-29-2015, 04:28 AM
Remove all 'select' and 'activate'.
Avoid any copying.
Disable calculation automatically.

Do not use workbooks.open but Getobject(filename)