I have made a spreadsheet which copies a heap of data from, many closed excel files in a specified folder. It runs fine on my computer at work but at home it starts to work then crashes a few cycles in. I am unsure of what the issue could be. This is the code
Sub runallmacros()
CommandButton1_Click
delrowsifzero
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1 As Worksheet
Dim Wb As Workbook, Filename As String
'User Selects desired Folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then GoTo Cleanup
SelFold = .SelectedItems(1)
End With
'All .xls* files in Selected FolderPath including Sub folders are put into an array
x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """& SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("sheet2")
'Loop through that array
For i = LBound(x) To UBound(x) - 1
'Open (in background) the Workbook
With GetObject(x(i))
ThisWorkbook.Sheets(1).UsedRange
Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
Set Wb = Workbooks(Filename)
Set ws = Nothing
On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("Builder Costings")
On Error GoTo 0
If Not ws Is Nothing Then
ws.Range("A1:C13").Copy
ws1.Range("A1:C13").Offset(lngrow).PasteSpecial xlPasteFormats
ws1.Range("A1:C13").Offset(lngrow).PasteSpecial xlPasteValues
ws.Range("H1:i2").Copy
ws1.Range("E1:f2").Offset(lngrow).PasteSpecial xlPasteFormats
ws1.Range("E1:f2").Offset(lngrow).PasteSpecial xlPasteValues
ws.Range("H3:h4").Copy
ws1.Range("d1:d2").Offset(lngrow).PasteSpecial xlPasteFormats
ws1.Range("d1:d2").Offset(lngrow).PasteSpecial xlPasteValues
ws.Range("A15:E279").Copy
ws1.Range("A14:E278").Offset(lngrow).PasteSpecial xlPasteFormats
ws1.Range("A14:E278").Offset(lngrow).PasteSpecial xlPasteValues
lngrow = lngrow + 279
ActiveSheet.Range("A1").Copy
End If
Wb.Close False
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub delrowsifzero()
Application.ScreenUpdating = False
Dim LastRow As Long
Worksheets("sheet2").Activate
On Error Resume Next
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A:a"& LastRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A:a"& LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = LastRow To 2 Step -1
If Cells(x, 2) = "" Or Cells(x, 2) = 0 Then
Rows(x).EntireRow.Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
Can someone please help me work out what is going on. I can't seem to figure it out.
the crash dump is as follows
Description Faulting Application Path: C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE
Problem signature Problem Event Name: APPCRASH Application Name: EXCEL.EXE Application Version: 16.0.12130.20344 Application Timestamp: 5dc608a2 Fault Module Name: VBE7.DLL Fault Module Version: 0.0.0.0 Fault Module Timestamp: 5d07efc9 Exception Code: c0000005 Exception Offset: 00000000000021b9 OS Version: 10.0.18362.2.0.0.768.101 Locale ID: 3081
Extra information about the problem Bucket ID: 077f50cf87ab5caca46705a64aab5c30 (1470150015135210544)