Macro stopped working please help!

[paquirl]

The code below is not working. I have several just like it that are working in the same report. I’m wondering if this one and the ones after it are not working because they are so far down on the report. If this is the problem, can the code be tweaked to work no matter where the account is on the report?

Thanks,
-Andrew


Sub LieNielsen()
'Working in 2000-2010
Selection.AutoFilter Field:=1, Criteria1:= _
"Lie Nielsen Tool Works, Warren ME (20031067)"
Range("B110").Select
ActiveWindow.SmallScroll Down:=-63
Range("A3:T401").Select
Range("B110").Activate
ActiveWindow.SmallScroll Down:=-42

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

Set Source = Nothing
On Error Resume Next
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, " & _
"please correct and try again.", vbOKOnly
Exit Sub
End If

If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
"You have more than one sheet selected." & vbNewLine & _
"You only selected one cell." & vbNewLine & _
"You selected more than one area." & vbNewLine & vbNewLine & _
"Please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Lie Nielsen Backorder Report"

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "jen@lie-nielsen.com"
.CC = ""
.BCC = ""
.Subject = "Lie Nielsen Backorder Report"
.Body = "Please find attached this week's backorder report. -Laurie"
.Attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Hermanito]

I don't feel like digging through a whole lot of code with no more pointer than "it doesn't work"

Your chances of getting help will increase exponentially if you at least give us some more information. For instance: in what line of code does it break, what error does it give, what is the purpose of the code?

 

[Ralajer]

I was able to run the code and generate an email with an attachment without errors. What is it meant to do that it is not doing?

 

[JackDanIce]

Agree exactly with Hermanito, believe it or not, when reading you're problem we can't magically become pyschic and know exactly where your problem occurs if you're going to post masses of code.

As it is, I have read through it all and one thing I found is you have one section as WITH - END WITH, immediately followed by another END WITH and I think that's where the issue is.

Have lightlighed in red what line I think you should delete:

Sub LieNielsen ()
'Working in 2000-2010
Selection.AutoFilter Field:=1, Criteria1:= _
"Lie Nielsen Tool Works, Warren ME (20031067)"
 
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
 
Set Source = Nothing
On Error Resume Next
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
 
If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, " & _
    "please correct and try again.", vbOKOnly
    Exit Sub
End If
 
If ActiveWindow.SelectedSheets.Count > 1 Or _
    Selection.Cells.Count = 1 Or _
    Selection.Areas.Count > 1 Then
    MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
    "You have more than one sheet selected." & vbNewLine & _
    "You only selected one cell." & vbNewLine & _
    "You selected more than one area." & vbNewLine & vbNewLine & _
    "Please correct and try again.", vbOKOnly
    Exit Sub
End If
 
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
 
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy

With Dest.Sheets(1).Cells(1)
    .PasteSpecial Paste:=8
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
    .Select
End With
 
TempFilePath = Environ$("temp") & "\"
TempFileName = "Lie Nielsen Backorder Report"
 
If Val(Application.Version) < 12 Then
    'You use Excel 2000-2003
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    'You use Excel 2007-2010
    FileExtStr = ".xlsx": FileFormatNum = 51
End If
 
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
 
With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, _
    FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
    .To = "jen@lie-nielsen.com"
    .CC = ""
    .BCC = ""
    .Subject = "Lie Nielsen Backorder Report"
    .Body = "Please find attached this week's backorder report. -Laurie"
    .Attachments.Add Dest.FullName
    'You can add other files also like this
    '.Attachments.Add ("C:\test.txt")
    .Display 'or use .Display
End With
    On Error GoTo 0
    .Close SaveChanges:=False
End With
 
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
 
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
 
End Sub

Delete the line of code in red and then test if the code works.
I also recommend better formatting/layout of your code to make it easier to read and also debug

 

[Ralajer]

JackDanIce,

The End With statements are fine they are just nested. The first End With closes the With OutMail the second closes With Dest. Not the cleanest code but still legal.

 

[JackDanIce]

D'oh missed that WITH MAIL part - thanks for the pointer Rob

 

[paquirl]

Please excuse my ignorance. I dont even know how to figure out where the code "breaks."

The issue is I have a report to work. I run the macros and an email message is generated with an attachment that is just that particular customer's account off the report. I have about a dozen macros like this; in fact they are all identical except for the customer's unique information on each one. The last three macros on my list produce an email with an attachment that is a blank spreadsheet.

 

[Ralajer]

The autofilter is based on the cells selection prior to running the macro so the problem may have to do with that. Also if the autofilter results in the Range("A3:T401") having no values visible it will also not copy or copy blanks. If the "Lie Nielsen Tool Works, Warren ME (20031067)" is in a row greater than 401 it will also cause some problems.

Could you relay how the data is laid out: how many rows, what row the data starts on, sheet name etc.

 

[paquirl]

In this week's report (bear in mind the rows change every week), Lie Nielsen starts on row 685 and goes to row 687. This week's report has 1124 total rows.

The autofilter line is row 3.

The report could be longer one week or shorter. Also, it can grow if we add more accounts. I would like for the macro to work no matter how many rows are on report.

 

[Ralajer]

That the problem the range that the code is looking at to copy consists of row 3 to 401 if the data is outside the range it will not copy. Try this code. I don't have your data to test against but it sets the range dynamically so it should adjust no matter the rows and columns.

Sub LieNielsen()

    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

[COLOR="Blue"][B]'// ——————————————————————————————————————————————————————————————————————————
'// CHANGES
'// ——————————————————————————————————————————————————————————————————————————
    Dim recordRng As Range
    Dim recordWS As Worksheet
    
    Set recordWS = ActiveSheet
    
    With recordWS
        .AutoFilterMode = False     '// Turn off Autofilter
        '// Set records to current region. Using A3 as an default cell
        '// in the region to define the range
        Set recordRng = .Range("A3").CurrentRegion
       
        .Range("A3").AutoFilter Field:=1, Criteria1:= _
            "Lie Nielsen Tool Works, Warren ME (20031067)"
    End With '//recordWS

    Set Source = Nothing
    On Error Resume Next
    Set Source = recordRng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
'// ——————————————————————————————————————————————————————————————————————————
'// END CHANGES
'// ——————————————————————————————————————————————————————————————————————————[/B][/COLOR]
    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, " & _
        "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
    If ActiveWindow.SelectedSheets.Count > 1 Or _
                        Selection.Cells.Count = 1 Or _
                        Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
                "You have more than one sheet selected." & vbNewLine & _
                "You only selected one cell." & vbNewLine & _
                "You selected more than one area." & vbNewLine & vbNewLine & _
                "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    
    Source.Copy
    
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
    End With
    
    Application.CutCopyMode = False
    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Lie Nielsen Backorder Report"
    
    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
        FileFormat:=FileFormatNum
        
        On Error Resume Next
        With OutMail
            .To = "jen@lie-nielsen.com"
            .CC = ""
            .BCC = ""
            .Subject = "Lie Nielsen Backorder Report"
            .Body = "Please find attached this week's backorder report. -Laurie"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display 'or use .Display
        End With
        On Error GoTo 0
        
        .Close SaveChanges:=False
    End With
    
    Kill TempFilePath & TempFileName & FileExtStr
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub