Edit VBA To Be Faster / Stop Excel Crashing

S

Stildawn

Board Regular
Joined
Aug 26, 2012
Messages
200
Hi All

I have this large set of code below.

Note:
  • That it is essentially the same code runs but with slight variations for each different type of sheet (determined by the Select Case) in the source file.
  • It runs through each line, and then builds new lines in the "Lines" sheet based on "A" and combination of column headers.
  • It runs very slowly, a full file run (4 sheets processed) is about 10 minutes.
  • It also crashes Excel, as in full Excel crash / closes, no longer is running in task manager. It does this most times, but not every time.
  • The code below, does exactly what I want it to do other than being slow and causing Excel to crash randomly.

VBA Code: 
Public myFolder As String
Public strInvFile As String
Public strFile As String
Public strUnprocessedSheets As String
Public strInvoice As String
Public strSupplier As String

Public Function ImportSpreadsheet(strInvFile As String, strFile As String)
Dim Lastrow As Integer
Dim LastrowL As Integer
Dim lngInstr As Long

Dim strUnprocessedSheets As String
Dim strInvoice As String
Dim strSupplier As String

Dim intHeaderRow As Integer
Dim strStyle As String
Dim strType As String
Dim strGender As String
Dim strMaterial As String
Dim strDesc As String
Dim strOrigin As String
Dim dblUnitPrice As Double

Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

strUnprocessedSheets = ""

strInvoice = ""
strSupplier = ""

intHeaderRow = 0
strStyle = ""
strType = ""
strGender = ""
strMaterial = ""
strDesc = ""
strOrigin = ""
dblUnitPrice = 0

ThisWorkbook.Sheets.Add.Name = "Data"


Workbooks.Open strInvFile, UpdateLinks:=False

For i = 1 To Workbooks(strFile).Sheets.Count
    Select Case Workbooks(strFile).Sheets(i).Name
        Case Is = "Supplier 1"
            'Supplier 1
            Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
           
            LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
 
            With ThisWorkbook.Sheets("Data")
                strInvoice = .Range("B2").Value
                strSupplier = "Supplier 1"
               
                .Rows("1:9").EntireRow.Delete
                Lastrow = .Range("W" & .Rows.Count).End(xlUp).Row
                .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
               
                .Columns("A:A").Delete
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = Lastrow To 1 Step -1
                    If IsEmpty(.Range("A" & r)) = True Then
                        .Rows(r & ":" & r).EntireRow.Delete
                    Else
                    End If
                Next r
                   
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = 1 To Lastrow
                    If .Range("A" & r).Value = "Style" Then
                        intHeaderRow = r
                    Else
                        strStyle = .Range("A" & r).Value
                        strType = .Range("C" & r).Value
                        strGender = .Range("E" & r).Value
                        strMaterial = .Range("G" & r).Value
                        strDesc = strGender & " " & strType & " " & strMaterial
                        strOrigin = .Range("D" & r).Value
                        dblUnitPrice = .Range("W" & r).Value
                   
                        For c = 8 To 21
                            If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                Else
                                    ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                    ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                    ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                    ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                    ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                    ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                    ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                    ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
                                   
                                    LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                End If
                            Else
                                'No size so skip
                            End If
                        Next c
                    End If
                Next r
            End With
 
            'Delete DATA and recreate
            ThisWorkbook.Sheets("Data").Delete
            ThisWorkbook.Sheets.Add.Name = "Data"

        Case Is = "Supplier 2"
            'Supplier 2
            Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
           
            LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
 
            With ThisWorkbook.Sheets("Data")
                strInvoice = .Range("B2").Value
                strSupplier = "Supplier 2"
               
                .Rows("1:9").EntireRow.Delete
                Lastrow = .Range("W" & .Rows.Count).End(xlUp).Row
                .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
               
                .Columns("A:A").Delete
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = Lastrow To 1 Step -1
                    If IsEmpty(.Range("A" & r)) = True Then
                        .Rows(r & ":" & r).EntireRow.Delete
                    Else
                    End If
                Next r
                   
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = 1 To Lastrow
                    If .Range("A" & r).Value = "Style" Then
                        intHeaderRow = r
                    Else
                        strStyle = .Range("A" & r).Value
                        strType = .Range("C" & r).Value
                        strGender = .Range("E" & r).Value
                        strMaterial = .Range("G" & r).Value
                        strDesc = strGender & " " & strType & " " & strMaterial
                        strOrigin = .Range("D" & r).Value
                        dblUnitPrice = .Range("W" & r).Value
                   
                        For c = 8 To 21
                            If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                Else
                                    ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                    ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                    ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                    ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                    ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                    ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                    ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                    ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
                                   
                                    LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                End If
                            Else
                                'No size so skip
                            End If
                        Next c
                    End If
                Next r
            End With
 
            'Delete DATA and recreate
            ThisWorkbook.Sheets("Data").Delete
            ThisWorkbook.Sheets.Add.Name = "Data"
           
        Case Is = "Supplier 3"
            'Supplier 3
            Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
         
            LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
 
            With ThisWorkbook.Sheets("Data")
                strInvoice = .Range("B2").Value
                strSupplier = "Supplier 3"
               
                .Rows("1:9").EntireRow.Delete
                Lastrow = .Range("V" & .Rows.Count).End(xlUp).Row
                .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
               
                .Columns("A:A").Delete
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = Lastrow To 1 Step -1
                    If IsEmpty(.Range("A" & r)) = True Then
                        .Rows(r & ":" & r).EntireRow.Delete
                    Else
                    End If
                Next r
                   
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = 1 To Lastrow
                    If .Range("A" & r).Value = "Style" Then
                        intHeaderRow = r
                    Else
                        strStyle = .Range("A" & r).Value
                        strType = .Range("C" & r).Value
                        strGender = .Range("E" & r).Value
                        strMaterial = .Range("G" & r).Value
                        strDesc = strGender & " " & strType & " " & strMaterial
                        strOrigin = .Range("D" & r).Value
                        dblUnitPrice = .Range("V" & r).Value
                   
                        For c = 8 To 20
                            If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                Else
                                    ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                    ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                    ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                    ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                    ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                    ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                    ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                    ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
                                   
                                    LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                End If
                            Else
                                'No size so skip
                            End If
                        Next c
                    End If
                Next r
            End With
       
            'Delete DATA and recreate
            ThisWorkbook.Sheets("Data").Delete
            ThisWorkbook.Sheets.Add.Name = "Data"
       
        Case Is = "Supplier 4"
            'Supplier 4
            Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
         
            LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
 
            With ThisWorkbook.Sheets("Data")
                strInvoice = .Range("B2").Value
                strSupplier = "Supplier 4"
               
                .Rows("1:9").EntireRow.Delete
                Lastrow = .Range("R" & .Rows.Count).End(xlUp).Row
                .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
               
                .Columns("A:A").Delete
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = Lastrow To 1 Step -1
                    If IsEmpty(.Range("A" & r)) = True Then
                        .Rows(r & ":" & r).EntireRow.Delete
                    Else
                    End If
                Next r
                   
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = 1 To Lastrow
                    If .Range("A" & r).Value = "Style" Then
                        intHeaderRow = r
                    Else
                        strStyle = .Range("A" & r).Value
                        strType = .Range("C" & r).Value
                        strGender = .Range("E" & r).Value
                        strMaterial = .Range("G" & r).Value
                        strDesc = strGender & " " & strType & " " & strMaterial
                        strOrigin = .Range("D" & r).Value
                        dblUnitPrice = .Range("R" & r).Value
                   
                        For c = 8 To 16
                            If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                Else
                                    ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                    ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                    ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                    ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                    ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                    ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                    ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                    ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
                                   
                                    LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                End If
                            Else
                                'No size so skip
                            End If
                        Next c
                    End If
                Next r
            End With
       
            'Delete DATA and recreate
            ThisWorkbook.Sheets("Data").Delete
            ThisWorkbook.Sheets.Add.Name = "Data"
       
        Case Else
            If strUnprocessedSheets = "" Then
                strUnprocessedSheets = Workbooks(strFile).Sheets(i).Name
            Else
                strUnprocessedSheets = strUnprocessedSheets & " / " & Workbooks(strFile).Sheets(i).Name & " / "
            End If
           
    End Select

    strInvoice = ""
    strSupplier = ""
   
    intHeaderRow = 0
    strStyle = ""
    strType = ""
    strGender = ""
    strMaterial = ""
    strDesc = ""
    strOrigin = ""
    dblUnitPrice = 0
Next i
       
Workbooks(strFile).Saved = True
Workbooks(strFile).Close

ThisWorkbook.Sheets("Data").Delete

Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

If strUnprocessedSheets = "" Then
    'Empty
Else
    lngInstr = InStr(1, strUnprocessedSheets, " / ")
    If lngInstr = 0 Then
        'No " / "
    Else
        strUnprocessedSheets = Left(strUnprocessedSheets, Len(strUnprocessedSheets) - 3)
    End If
       
    MsgBox "Spreadsheet imported successfully." & vbNewLine & vbNewLine & "However the below sheets were not processed:" & vbNewLine & vbNewLine & strUnprocessedSheets, vbInformation, "Process Compelted"
End If

End Function

Any help would be greatly appreciated.
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
That's a rather ginormous block of code there. Perhaps try the following:
- turn off calculations
- step through the code to see if other events are triggering code. If so ...
- disable events; sometimes this property is ignored so consider a public variable (e.g. bolNoEvents as Boolean) and set at the outset of the procedure. You will have to go to those events and test the boolean and exit sub or function according to boolean value (True makes sense to me).
- use vbNullString instead of "" where required.
- default value for strings is already a zero length string - no need to set unless it needs to be reset (or if global and might contain a value)
- default value for numeric variables is zero; no need to set to zero unless it needs to be reset. Same as above.
- default value for boolean is False, same as above
- disable status bar, page breaks and alerts
- use multi line declarations:
Dim intHeaderRow As Integer
Dim strStyle As String, strType As String, strGender As String, strMaterial As String
Dim strDesc As String, Dim strOrigin As String
Dim dblUnitPrice As Double
Note: I group by type and don't spread them throughout the code blocks, but the latter point is personal preference and not speed related.

- Declare and use objects and with statements:
VBA Code: 
Dim wb As Workbook
Set wb = ThisWorkbook.Sheets("Lines")
With wb
    .Range("A" & LastrowL + 1).Value = strSupplier
    .etc
End With
- if your code uses then no longer requires an object variable, consider recovering the system memory that it takes up rather than wait until the end. I recommend recovery at the end of a procedure (e.g. Set objMyObjectName = Nothing) at the end of the procedure. This ensures that memory is regained as soon as the procedure ends rather than waiting for the application to perform its garbage collection.
Whenever I disable application level settings I use an error handler lest they get left that way.

That's all I can think of for now.
 
Last edited:
Upvote 0
I hope you'll find someone that's willing to wade through 350 lines of code to find the problem.
You might be better off to explain in detail but in a concise manner what you want to achieve.
 
Upvote 0
I know it looks like a lot, cause I didn't want to miss anything out, but really its mostly a bunch of supporing code, and then 4 blocks of near identical code.

This is one block of code below, the other 3 are essentially identical but with different cell references etc:

VBA Code: 
'Supplier 1
            Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
           
            LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
 
            With ThisWorkbook.Sheets("Data")
                strInvoice = .Range("B2").Value
                strSupplier = "Supplier 1"
               
                .Rows("1:9").EntireRow.Delete
                Lastrow = .Range("W" & .Rows.Count).End(xlUp).Row
                .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
               
                .Columns("A:A").Delete
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = Lastrow To 1 Step -1
                    If IsEmpty(.Range("A" & r)) = True Then
                        .Rows(r & ":" & r).EntireRow.Delete
                    Else
                    End If
                Next r
                   
                Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
               
                For r = 1 To Lastrow
                    If .Range("A" & r).Value = "Style" Then
                        intHeaderRow = r
                    Else
                        strStyle = .Range("A" & r).Value
                        strType = .Range("C" & r).Value
                        strGender = .Range("E" & r).Value
                        strMaterial = .Range("G" & r).Value
                        strDesc = strGender & " " & strType & " " & strMaterial
                        strOrigin = .Range("D" & r).Value
                        dblUnitPrice = .Range("W" & r).Value
                   
                        For c = 8 To 21
                            If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                Else
                                    ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                    ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                    ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                    ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                    ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                    ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                    ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                    ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
                                   
                                    LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                End If
                            Else
                                'No size so skip
                            End If
                        Next c
                    End If
                Next r
            End With
 
            'Delete DATA and recreate
            ThisWorkbook.Sheets("Data").Delete
            ThisWorkbook.Sheets.Add.Name = "Data"

Micron said:
That's a rather ginormous block of code there. Perhaps try the following:
- turn off calculations
- step through the code to see if other events are triggering code. If so ...
- disable events; sometimes this property is ignored so consider a public variable (e.g. bolNoEvents as Boolean) and set at the outset of the procedure. You will have to go to those events and test the boolean and exit sub or function according to boolean value (True makes sense to me).
- use vbNullString instead of "" where required.
- default value for strings is already a zero length string - no need to set unless it needs to be reset (or if global and might contain a value)
- default value for numeric variables is zero; no need to set to zero unless it needs to be reset. Same as above.
- default value for boolean is False, same as above
- disable status bar, page breaks and alerts
- use multi line declarations:
Dim intHeaderRow As Integer
Dim strStyle As String, strType As String, strGender As String, strMaterial As String
Dim strDesc As String, Dim strOrigin As String
Dim dblUnitPrice As Double
Note: I group by type and don't spread them throughout the code blocks, but the latter point is personal preference and not speed related.

- Declare and use objects and with statements:
VBA Code: 
Dim wb As Workbook
Set wb = ThisWorkbook.Sheets("Lines")
With wb
    .Range("A" & LastrowL + 1).Value = strSupplier
    .etc
End With
- if your code uses then no longer requires an object variable, consider recovering the system memory that it takes up rather than wait until the end. I recommend recovery at the end of a procedure (e.g. Set objMyObjectName = Nothing) at the end of the procedure. This ensures that memory is regained as soon as the procedure ends rather than waiting for the application to perform its garbage collection.
Whenever I disable application level settings I use an error handler lest they get left that way.

That's all I can think of for now.
Click to expand...

The main issue is that currently 9 times of our 10 this code crashes Excel to exit. I find that super weird, cause the times it does complete it completes perfectly as I intended.

Will work through your list above, but as I said its hard cause no lines cause any issues, just crashes Excel.

I've even ran this on my 24 core / 36gb ram PC and it still had the same issues, as my less powerful work laptops.

Would it make a big difference if I created a "Data" sheet for each of the 4 suppliers (or 4 source file sheets) and copy the data in all at once and then close the source sheet?


jolivanes said:
I hope you'll find someone that's willing to wade through 350 lines of code to find the problem.
You might be better off to explain in detail but in a concise manner what you want to achieve.
Click to expand...

Yeah its a large dump, but I have posted a shorter more confined bit above.
 
Upvote 0
Personally I prefer not to go through code that does not work as intended. You drive a truck to work while I take my bike. We both get there just in a different way. Same with code.
If you explain in a concise manner what is needed, people will supply you with suggestions that I would say are different from what you have here. Micron mentioned this in his post.
 
Upvote 0
Regretfully, I concentrated on speed and forgot to add about crashing. If neither I or anyone else is able to spot potential crash points (my excuse would be that I"m primarily fluent in Access vba and am not likely to spot crash causing code in Excel) then there is something you can add that may narrow down the issue. Consider an error handler, declare an error string and populate it at points where an operation or block of code begins and have the handler write the string to a log file.
Example
VBA Code: 
'declarations section
Dim strErr As String

On Error GoTo errHandler
'more code
'Supplier 1
strErr = " Supplier 1 sheet copy"
Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
'more code then new error message where you see fit
strErr = "?????"
'more code
'end of your code
exitHere:
'reset environment settings, set objects to Nothing
Exit Sub

errHandler:
'code to write to log file in same folder as wb. Call the function below or put its code here. 
'I would include the application error number and description along with strErr. 
'Perhaps like (if calling function below):
WriteToUpdateLog("Error " & Err.Number & ": " & Err.Description & vbCrLf & strErr)
Resume exitHere

Example of write to log code written for Access so may not work verbatim. Need a reference to File Scripting Object.
VBA Code: 
Public Function WriteToUpdateLog(strMsg As String)
Dim fs, f
Dim fpath As String
Const ForReading = 1, ForWriting = 2, ForAppending = 8

fpath = CurrentProject.Path & "\QueryUpdateLog.log"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(fpath, 8, True)
f.Write strMsg
f.Close 'closes file & saves changes
Set fs = Nothing
Set f = Nothing
'Application.FollowHyperlink fpath 'opens the file to display success/failure.
End Function
NOTE- at this point I'm thinking you may end up needing a different approach. If wb crashes it may not write to file. If not, use the function approach and write to the file at the beginning of every operation. What you will get in that case is the last successful operation logged and not the one that failed (because the error handler would not be logging that failure). I think I would leave let the handler write to the file as well. You would know it came from the handler because of the supporting text around the error number and description. You would have to decide to overwrite vs append because of the write occurring at the start of each operation and maybe include date/time if appending. The whole point of this is to narrow down where the code fails.
 
Upvote 0
Random comments/questions.

Why do you declare some variables, but leave others undefined? Whichever you choose (declare or don't declare), you should be consistent.

Most of your code is four sections that basically repeat w/ few loop count changes. You should start by modularizing your code to better your chances of isolating the crash-prone code.

What is this line for?:

VBA Code: 
              .Rows(Lastrow + 1 & ":65536").EntireRow.Delete

It looks like something left over from an ancient version of Excel when the max number of rows was 65535 . FWIW, you should update your profile to indicate the version you are using.
 
Upvote 0
@Stildawn, I looked through your code & I am thinking your Excel crashing is most like due to the variable 'intHeaderRow'. You are setting that = 0 initially for each loop, but you are not always changing that value in the code, if the value is still = 0 when you hit .Cells(intHeaderRow, c) that is going to be a problem.

I have shortened up your code so that it is not as large to look at, I didn't make any corrections, so you will have to address the issue that I mentioned, for starters.

VBA Code: 
'
    Public myFolder             As String
'
    Public strFile              As String
    Public strInvFile           As String
'
    Public strInvoice           As String
    Public strSupplier          As String
    Public strUnprocessedSheets As String
'
Public Function ImportSpreadsheet(strInvFile As String, strFile As String)
'
    Dim dblUnitPrice            As Double
'
    Dim intHeaderRow            As Integer
    Dim lngInstr                As Long
    Dim Lastrow                 As Integer
    Dim LastrowL                As Integer
    Dim strSupplierMaxLoop      As Long
'
    Dim strDesc                 As String
    Dim strGender               As String
    Dim strInvoice              As String
    Dim strMaterial             As String
    Dim strOrigin               As String
    Dim strStyle                As String
    Dim strSupplier             As String
    Dim strSupplierColumn       As String
    Dim strType                 As String
    Dim strUnprocessedSheets    As String
'
    Application.AskToUpdateLinks = False
       Application.DisplayAlerts = False
      Application.ScreenUpdating = False
'
    ThisWorkbook.Sheets.Add.Name = "Data"
'
    Workbooks.Open strInvFile, UpdateLinks:=False
'
    For i = 1 To Workbooks(strFile).Sheets.Count
        Select Case Workbooks(strFile).Sheets(i).Name
            Case Is = "Supplier 1", "Supplier 2", "Supplier 3", "Supplier 4"
                Select Case Workbooks(strFile).Sheets(i).Name
                    Case Is = "Supplier 1"
                        strSupplier = "Supplier 1"
                        strSupplierColumn = "W"
                        strSupplierMaxLoop = 21
                    Case Is = "Supplier 2"
                        strSupplier = "Supplier 2"
                        strSupplierColumn = "W"
                        strSupplierMaxLoop = 21
                    Case Is = "Supplier 3"
                        strSupplier = "Supplier 3"
                        strSupplierColumn = "V"
                        strSupplierMaxLoop = 20
                    Case Is = "Supplier 4"
                        strSupplier = "Supplier 4"
                        strSupplierColumn = "R"
                        strSupplierMaxLoop = 16
                End Select
'
'
'
                Workbooks(strFile).Sheets(i).Cells.Copy ThisWorkbook.Sheets("Data").Range("A1")
'
                LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
'
                With ThisWorkbook.Sheets("Data")
                    strInvoice = .Range("B2").Value
'
                    .Rows("1:9").EntireRow.Delete
'
                    Lastrow = .Range(strSupplierColumn & .Rows.Count).End(xlUp).Row
                    .Rows(Lastrow + 1 & ":65536").EntireRow.Delete
'
                    .Columns("A:A").Delete
                    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'
                    For r = Lastrow To 1 Step -1
                        If IsEmpty(.Range("A" & r)) = True Then
                            .Rows(r & ":" & r).EntireRow.Delete
                        Else
                        End If
                    Next r
'
                    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'
                    For r = 1 To Lastrow
                        If .Range("A" & r).Value = "Style" Then
                            intHeaderRow = r
                        Else
                            strStyle = .Range("A" & r).Value
                            strType = .Range("C" & r).Value
                            strGender = .Range("E" & r).Value
                            strMaterial = .Range("G" & r).Value
                            strDesc = strGender & " " & strType & " " & strMaterial
                            strOrigin = .Range("D" & r).Value
                            dblUnitPrice = .Range(strSupplierColumn & r).Value
'
                            For c = 8 To strSupplierMaxLoop
                                If IsEmpty(.Cells(intHeaderRow, c)) = False Then
                                    If .Cells(r, c).Value = 0 Then
                                    'No QTY so skip
                                    Else
                                        ThisWorkbook.Sheets("Lines").Range("A" & LastrowL + 1).Value = strSupplier 'Supplier
                                        ThisWorkbook.Sheets("Lines").Range("B" & LastrowL + 1).Value = strInvoice 'Invoice
                                        ThisWorkbook.Sheets("Lines").Range("C" & LastrowL + 1).Value = strStyle & "-" & .Cells(intHeaderRow, c).Value 'Product
                                        ThisWorkbook.Sheets("Lines").Range("D" & LastrowL + 1).Value = strDesc 'Spreadsheet Description
                                        ThisWorkbook.Sheets("Lines").Range("H" & LastrowL + 1).Value = .Cells(r, c).Value 'QTY
                                        ThisWorkbook.Sheets("Lines").Range("I" & LastrowL + 1).Value = "UNT" 'UNT
                                        ThisWorkbook.Sheets("Lines").Range("J" & LastrowL + 1).Value = .Cells(r, c).Value * dblUnitPrice 'PRICE
                                        ThisWorkbook.Sheets("Lines").Range("K" & LastrowL + 1).Value = strOrigin 'Origin
'
                                        LastrowL = ThisWorkbook.Sheets("Lines").Range("C" & ThisWorkbook.Sheets("Lines").Rows.Count).End(xlUp).Row
                                    End If
                                Else
                                'No size so skip
                                End If
                            Next c
                        End If
                    Next r
                End With
 '
                'Delete DATA and recreate
                ThisWorkbook.Sheets("Data").Delete
                ThisWorkbook.Sheets.Add.Name = "Data"
'
            Case Else
                If strUnprocessedSheets = "" Then
                    strUnprocessedSheets = Workbooks(strFile).Sheets(i).Name
                Else
                    strUnprocessedSheets = strUnprocessedSheets & " / " & Workbooks(strFile).Sheets(i).Name & " / "
                End If
        End Select
'
        dblUnitPrice = 0
        intHeaderRow = 0
'
        strDesc = ""
        strGender = ""
'        strInvoice = ""
        strMaterial = ""
        strOrigin = ""
        strStyle = ""
'        strSupplier = ""
        strType = ""
    Next i
'
    Workbooks(strFile).Saved = True
    Workbooks(strFile).Close
'
    ThisWorkbook.Sheets("Data").Delete
'
    Application.AskToUpdateLinks = True
       Application.DisplayAlerts = True
      Application.ScreenUpdating = True
'
    If strUnprocessedSheets = "" Then
    'Empty
    Else
        lngInstr = InStr(1, strUnprocessedSheets, " / ")
'
        If lngInstr = 0 Then
        'No " / "
        Else
            strUnprocessedSheets = Left(strUnprocessedSheets, Len(strUnprocessedSheets) - 3)
        End If
'
        MsgBox "Spreadsheet imported successfully." & vbNewLine & vbNewLine & "However the below sheets were not processed:" & vbNewLine & vbNewLine & strUnprocessedSheets, vbInformation, "Process Compelted"
    End If
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Dynamic Sum Range Addresses...(?)
Replies
2
Views
469
Kenny_D
K
K
  • Question Question
Excel VBA - Element not found error
Replies
0
Views
124
kyk8898
K
R
  • Question Question
Runtime Error 91
2
Replies
15
Views
610
rtr1811
R
U
  • Question Question
Text Value from Textbox to Integer
Replies
1
Views
312
Kaper
Kaper
F
  • Question Question
VBA Code for Named Ranges
Replies
2
Views
572
fishandtril
F

Forum statistics

Threads
1,223,099
Messages
6,170,108
Members
452,302
Latest member
TaMere

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top