Unexplained Macro Lag between different Spreadsheets(Reports) for same code

I have a couple sets of virtually the same macro to send blast emails from a report created by an ERP system.

There are 4 different ERP systems utilized to create 4 different reports with the same general information. Some have more detail than others as well as different styles of formatting.

The first 2 ran smoothly, averaging about 3 seconds per email. Each report had about 4000 lines of invoice data that were sent through 750-800 emails. Each file was about 4500 KB in size.

But, when I got to the third ERP system, my below code took forever to run through the initial formatting section, and would then send an email about once a minute. This ERP Report had over 10,000 lines of invoice data. This report had more formatting than the previous two as well as some additional columns of information to be removed. The file size was about 9-10,000 KB in size.

When I exit the macro after a few minutes of it running slowly, the code in Bold/Red below is commonly where the debugger will cause problems. (I've also attached a sample of the workbook I'm using and replaced any sensitive information with Generic info or symbols to signify their input values)

Sub Send_Rows()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet
    Dim StrBody1 As String
    Dim StrBody2 As String
    Dim TodaysDate As String
    Dim SpFirstName As String
    Dim SpLastName As String
    Dim SpNum As String
    Dim CustName As String
    Dim CustNum As String
    Dim Entity As String
    Dim SpEmail As String

    'Turn of screen updating until macro's complete
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Insert Column to the left of Customer Emails
    Columns("AL:AL").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    'Copies and pastes Emails into Column that was inserted
    Columns("AK:AK").Select
    Selection.Copy
    Columns("AL:AL").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'Insert formula to remove duplicates and leave blank rows
    Range("AL2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=IF(R[1]C[-1]=RC[-1],"""",RC[-1])"
    Range("AL2").Select
    Selection.AutoFill Destination:=Range("AL2:AL" & LastRow(ActiveSheet))
    
    'Copies and pastes formulas as values in same Column
    Range("AL2:AL" & LastRow(ActiveSheet)).Select
    Columns("AL:AL").Select
    Selection.Copy
    Range("AL1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'Inserts Column and adds phone number to all cells through the last active row to the left of Collector Name
    Columns("AM:AM").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("AM2").Select
    ActiveCell.Value = "1-8##-###-####"
    Range("AM2").Select
    Selection.Copy
    Range("AM2:AM" & LastRow(ActiveSheet)).Select
    ActiveSheet.Paste

    'Text to Columns Specialist Name for Email purposes later in macro
    Columns("AN:AN").Select
    Selection.TextToColumns Destination:=Range("AN1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

 
   'Loop to cycle through each cell in the specified range and replaces all characters in lowercase
   For Each x In Range("AK2:AL" & LastRow(ActiveSheet))
      x.Value = LCase(x.Value)
   Next

 'Selects entire worksheet and adds borders
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    'Selects the top row and gives it a light grey tint to show headers 
    Rows("1:1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With

    'Auto Fits entire worksheet so column values aren't hidden when copied
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit

    Set Ash = ActiveSheet
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
  
    'Filters customer data by email address in by criteria
    For Each cell In Ash.Columns("AL").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" _
           And LCase(cell.Offset(0, -1).Value) = cell.Value Then

            Ash.Range("A1:AO" & LastRow(ActiveSheet)).AutoFilter Field:=37, Criteria1:=cell.Value

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)
            
            CustNum = cell.Offset(0, -33)
            CustName = cell.Offset(0, -34)
            SpFirstName = cell.Offset(0, 2)
            SpLastName = cell.Offset(0, 3)
            SpNum = cell.Offset(0, 1)
            Entity = cell.Offset(0, -37)
            TodaysDate = Date
            
            SpEmail = SpFirstName & "." & SpLastName & "@email.com"
            
            StrBody1 = Email Header - not subject line

            StrBody2 = Email Body
                       
            On Error Resume Next
            
            'Populates email
            With OutMail
                .SentOnBehalfOfName = "abc@email.com"
                .To = cell.Value
                .Subject = "*" & Entity & "*" & " customer " & CustName & " #" & CustNum & " Past Due"
                .HTMLBody = StrBody1 & RangetoHTML(rng) & StrBody2
                .Display
            End With
            On Error GoTo 0

            Set OutMail = Nothing
            Ash.AutoFilterMode = False
        End If
    Next cell

'Undo formatting/adding of columns/text to columns done at beginning of macro
    Columns("AL:AM").Select
    Selection.Delete Shift:=xlToLeft
    Range("AN1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],"" "",RC[-1])"
    Range("AN1").Select
    Selection.AutoFill Destination:=Range("AN1:AN" & LastRow(ActiveSheet))
    Columns("AN:AN").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("AL:AM").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft

    Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub


Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim lr As Long
     
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        
        'Delete's columns not needed
        .Range("B:C").Delete
        .Range("D:D").Delete
        .Range("E:M").Delete
        .Range("F:F").Delete
        .Range("G:T").Delete
        .Range("H:P").Delete
        
        'Insert's "TOTAL" and SUM() Formula in Columns G & F after last active row and adds top/double bottom border
        lr = .Cells(Rows.Count, "G").End(3).Row
        .Range("G" & lr + 1).Formula = "=SUM(G2:G" & lr & ")"
        .Range("F" & lr + 1).Value = "TOTAL:"
        .Range("G" & lr + 1).Font.Bold = True
        .Range("F" & lr + 1).Font.Bold = True
        With Range("G" & lr + 1, "F" & lr + 1)
            With .Rows(.Rows.Count)
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
            End With
        End With
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function LastRow(sh As Worksheet)
    On Error Resume Next
    'Finds the last row of data on the excel spreadsheet
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

I got around this by inserting a new worksheet on the same workbook, copy/pasting about half of the report into the new sheet and then running the code, then once completed I'd copy in the other half and run the macro again. I didn't change/add/remove any formatting and it ran just as quick as the prior two reports had.

http://www.excelforum.com/attachment...1&d=1464129274

Does anyone have any ideas on what could be causing this?