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
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