VBA to format sheet worked yesterday...today it is broken

ohiojarhead

New Member
Joined
Jan 23, 2014
Messages
28
I would greatly appreciate any help on this as I am out of ideas. We have an application that is used to track inventory shortages. The app allows us to download the information into an excel sheet. The problem is that there is a lot of information in the app (designed for corporate level view) that is not necessary (workcenter view). Naturally I wrote a macro to process the workbook for me. Here is my code
Code:
Public Sub Shortage_Macro()</SPAN>
'Variables</SPAN>
 
 
'Turn off screen updating</SPAN>
Application.ScreenUpdating = False</SPAN>
 
'Re-name first worksheet</SPAN>
Sheets(1).Select</SPAN>
ActiveSheet.Name = "PartShortageBuyer"</SPAN>
 
'Delete Un-needed data</SPAN>
Range("A:A,G:K,O:Q,S:T,V:Y,AA:AI,AK:AV").Delete</SPAN>
 
'Change Waybill and PO to Number Format for proper display</SPAN>
Range("G:G").NumberFormat = "0"</SPAN>
Range("K:K").NumberFormat = "0"</SPAN>
 
'Align all data to the left</SPAN>
Range("A:L").HorizontalAlignment = xlLeft</SPAN>
 
'Create new sheet for shortages without shipping information</SPAN>
Sheets.Add After:=Sheets(Sheets.Count)</SPAN>
    Sheets("Sheet1").Select</SPAN>
    Sheets("Sheet1").Name = "MissingShippingInfo"</SPAN>
Sheets("PartShortageBuyer").Range("A1:L1").Copy</SPAN>
Sheets("MissingShippingInfo").Range("A1:L1").PasteSpecial</SPAN>
 
'Search for records missing shipping info and move them to the second sheet</SPAN>
Sheets("PartShortageBuyer").Activate</SPAN>
For i = 2 To Range("A2").End(xlDown).Row()</SPAN>
If Range("F" & i).Value = "" Or Range("G" & i).Value = "" Or Range("H" & i).Value = "" Then</SPAN>
Range("A" & i).EntireRow.Cut</SPAN>
Sheets("MissingShippingInfo").Activate</SPAN>
ActiveSheet.Range("A1").Select</SPAN>
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select</SPAN>
ActiveSheet.Paste</SPAN>
End If</SPAN>
Next i</SPAN>
 
 
Sheets("MissingShippingInfo").Range("A1").Select</SPAN>
Sheets("PartShortageBuyer").Activate</SPAN>
Range("A1").Select</SPAN>
'Sort based on shortage</SPAN>
 Columns("A:A").Select</SPAN>
    ActiveWorkbook.Worksheets("PartShortageBuyer").Sort.SortFields.Clear</SPAN>
    ActiveWorkbook.Worksheets("PartShortageBuyer").Sort.SortFields.Add Key:=Range _</SPAN>
        ("A2:A22"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _</SPAN>
        xlSortNormal</SPAN>
    With ActiveWorkbook.Worksheets("PartShortageBuyer").Sort</SPAN>
        .SetRange Range("A1:L22")</SPAN>
        .Header = xlYes</SPAN>
        .MatchCase = False</SPAN>
        .Orientation = xlTopToBottom</SPAN>
        .SortMethod = xlPinYin</SPAN>
        .Apply</SPAN>
    End With</SPAN>
   
 
'Size columns for first tab</SPAN>
Sheets("PartShortageBuyer").Activate</SPAN>
    Columns("A").ColumnWidth = 8.14</SPAN>
    Columns("B").ColumnWidth = 5</SPAN>
    Columns("C").ColumnWidth = 20</SPAN>
    Columns("D").ColumnWidth = 7</SPAN>
    Columns("E").ColumnWidth = 12.43</SPAN>
    Columns("F").ColumnWidth = 14.29</SPAN>
    Columns("G").ColumnWidth = 15</SPAN>
    Columns("H").ColumnWidth = 14.43</SPAN>
    Columns("I").ColumnWidth = 35</SPAN>
    Columns("J").ColumnWidth = 7.86</SPAN>
    Columns("K").ColumnWidth = 10.43</SPAN>
    Columns("L").ColumnWidth = 12</SPAN>
 
ActiveWindow.DisplayGridlines = False</SPAN>
'Set borders</SPAN>
Range("A1").Select</SPAN>
ActiveCell.CurrentRegion.Select</SPAN>
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone</SPAN>
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone</SPAN>
    With Selection.Borders</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .Color = -1316633</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlThin</SPAN>
    End With</SPAN>
 
'Format Header Row</SPAN>
Range("A1").Select</SPAN>
Range(Selection, Selection.End(xlToRight)).Select</SPAN>
    With Selection.Interior</SPAN>
        .Pattern = xlSolid</SPAN>
        .PatternColorIndex = xlAutomatic</SPAN>
        .Color = 6764288</SPAN>
        .TintAndShade = 0</SPAN>
        .PatternTintAndShade = 0</SPAN>
    End With</SPAN>
    With Selection.Font</SPAN>
        .Color = -2896181</SPAN>
        .TintAndShade = 0</SPAN>
    End With</SPAN>
 
'Print Setup</SPAN>
ActiveSheet.PageSetup.PrintArea = Range("A1").CurrentRegion.Address</SPAN>
With ActiveSheet.PageSetup</SPAN>
        .LeftMargin = Application.InchesToPoints(0.7)</SPAN>
        .RightMargin = Application.InchesToPoints(0.7)</SPAN>
        .TopMargin = Application.InchesToPoints(0.75)</SPAN>
        .BottomMargin = Application.InchesToPoints(0.75)</SPAN>
        .HeaderMargin = Application.InchesToPoints(0.3)</SPAN>
        .FooterMargin = Application.InchesToPoints(0.3)</SPAN>
        .PrintHeadings = False</SPAN>
        .PrintGridlines = False</SPAN>
        .PrintComments = xlPrintNoComments</SPAN>
        .PrintQuality = 600</SPAN>
        .CenterHorizontally = False</SPAN>
        .CenterVertically = False</SPAN>
        .Orientation = xlLandscape</SPAN>
        .Draft = False</SPAN>
        .PaperSize = xlPaperLetter</SPAN>
        .FirstPageNumber = xlAutomatic</SPAN>
        .Order = xlDownThenOver</SPAN>
        .BlackAndWhite = False</SPAN>
        .Zoom = False</SPAN>
        .FitToPagesWide = 1</SPAN>
        .PrintErrors = xlPrintErrorsDisplayed</SPAN>
        .OddAndEvenPagesHeaderFooter = False</SPAN>
        .DifferentFirstPageHeaderFooter = False</SPAN>
        .ScaleWithDocHeaderFooter = True</SPAN>
        .AlignMarginsHeaderFooter = True</SPAN>
End With</SPAN>
 
 
'Size columns for second tab</SPAN>
Sheets("MissingShippingInfo").Activate</SPAN>
    Sheets("MissingShippingInfo").Columns("A").ColumnWidth = 8.14</SPAN>
    Sheets("MissingShippingInfo").Columns("B").ColumnWidth = 5</SPAN>
    Sheets("MissingShippingInfo").Columns("C").ColumnWidth = 20</SPAN>
    Sheets("MissingShippingInfo").Columns("D").ColumnWidth = 7</SPAN>
    Sheets("MissingShippingInfo").Columns("E").ColumnWidth = 12.43</SPAN>
    Sheets("MissingShippingInfo").Columns("F").ColumnWidth = 14.29</SPAN>
    Sheets("MissingShippingInfo").Columns("G").ColumnWidth = 15</SPAN>
    Sheets("MissingShippingInfo").Columns("H").ColumnWidth = 14.43</SPAN>
    Sheets("MissingShippingInfo").Columns("I").ColumnWidth = 35</SPAN>
    Sheets("MissingShippingInfo").Columns("J").ColumnWidth = 7.86</SPAN>
    Sheets("MissingShippingInfo").Columns("K").ColumnWidth = 10.43</SPAN>
    Sheets("MissingShippingInfo").Columns("L").ColumnWidth = 12</SPAN>
 
ActiveWindow.DisplayGridlines = False</SPAN>
'Set borders</SPAN>
Sheets("MissingShippingInfo").Range("A1").Select</SPAN>
ActiveCell.CurrentRegion.Select</SPAN>
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone</SPAN>
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone</SPAN>
    With Selection.Borders</SPAN>
        .LineStyle = xlContinuous</SPAN>
        .Color = -1316633</SPAN>
        .TintAndShade = 0</SPAN>
        .Weight = xlThin</SPAN>
    End With</SPAN>
 
'Format Header Row</SPAN>
Sheets("MissingShippingInfo").Range("A1").Select</SPAN>
Sheets("MissingShippingInfo").Range(Selection, Selection.End(xlToRight)).Select</SPAN>
    With Selection.Interior</SPAN>
        .Pattern = xlSolid</SPAN>
        .PatternColorIndex = xlAutomatic</SPAN>
        .Color = 6764288</SPAN>
        .TintAndShade = 0</SPAN>
        .PatternTintAndShade = 0</SPAN>
    End With</SPAN>
    With Selection.Font</SPAN>
        .Color = -2896181</SPAN>
        .TintAndShade = 0</SPAN>
    End With</SPAN>
 
'Print Setup</SPAN>
ActiveSheet.PageSetup.PrintArea = Range("A1").CurrentRegion.Address</SPAN>
With ActiveSheet.PageSetup</SPAN>
        .LeftMargin = Application.InchesToPoints(0.7)</SPAN>
        .RightMargin = Application.InchesToPoints(0.7)</SPAN>
        .TopMargin = Application.InchesToPoints(0.75)</SPAN>
        .BottomMargin = Application.InchesToPoints(0.75)</SPAN>
        .HeaderMargin = Application.InchesToPoints(0.3)</SPAN>
        .FooterMargin = Application.InchesToPoints(0.3)</SPAN>
        .PrintHeadings = False</SPAN>
        .PrintGridlines = False</SPAN>
        .PrintComments = xlPrintNoComments</SPAN>
        .PrintQuality = 600</SPAN>
        .CenterHorizontally = False</SPAN>
        .CenterVertically = False</SPAN>
        .Orientation = xlLandscape</SPAN>
        .Draft = False</SPAN>
        .PaperSize = xlPaperLetter</SPAN>
        .FirstPageNumber = xlAutomatic</SPAN>
        .Order = xlDownThenOver</SPAN>
        .BlackAndWhite = False</SPAN>
        .Zoom = False</SPAN>
        .FitToPagesWide = 1</SPAN>
        .PrintErrors = xlPrintErrorsDisplayed</SPAN>
        .OddAndEvenPagesHeaderFooter = False</SPAN>
        .DifferentFirstPageHeaderFooter = False</SPAN>
        .ScaleWithDocHeaderFooter = True</SPAN>
        .AlignMarginsHeaderFooter = True</SPAN>
End With</SPAN>
 
'Notify Buyers of records missing SHipping info</SPAN>
 
'Tidy up</SPAN>
Sheets("MissingShippingInfo").Range("A1").Select</SPAN>
Sheets("PartShortageBuyer").Activate</SPAN>
Range("A1").Select</SPAN>
 
 
 
Application.ScreenUpdating = True</SPAN>
End Sub
This worked like a charm yesterday. Today I was given the additional task of having the report emailed to the buyers that have shortages that are missing the shipping info. I added this code from Ron de Bruin.
Code:
Public Sub Send_Sheets_Notes_Email()</SPAN>
 
  'Notes parameter for attaching the Excel files.</SPAN>
  Const EMBED_ATTACHMENT As Long = 1454</SPAN>
 
  'A folder to temporarily store the created Excel files in.</SPAN>
  Const stPath As String = "c:\temp"</SPAN>
 
  'The subject for the outgoing e-mails.</SPAN>
  Const stSubject As String = "Shortage Report - Missing Shipping Data"</SPAN>
 
  'The message in the bodies of the outgoing e-mails.</SPAN>
  Const vaMsg As Variant = "Please review the attached spreadsheet for the missing data and then update the shortage app." & vbCrLf & _</SPAN>
      "[URL]https://www.google.com[/URL]" & vbCrLf & _</SPAN>
      "" & vbCrLf & _</SPAN>
      "" & vbCrLf & _</SPAN>
      "Respectfully," & vbCrLf & _</SPAN>
      "Name"</SPAN>
 
  'Variable that holds the list of recipients for each worksheet.</SPAN>
  Dim vaRecipients As Variant</SPAN>
 
  'Variable which holds each worksheet's name.</SPAN>
  Dim stFileName As String</SPAN>
 
  'Variables for Notes.</SPAN>
  Dim noSession As Object</SPAN>
  Dim noDatabase As Object</SPAN>
  Dim noDocument As Object</SPAN>
  Dim noEmbedObject As Object</SPAN>
  Dim noAttachment As Object</SPAN>
  Dim stAttachment As String</SPAN>
 
  'Variables for Excel.</SPAN>
  Dim wbBook As Workbook</SPAN>
  Dim wsSheet As Worksheet</SPAN>
  Dim lnLastRow As Long</SPAN>
 
  On Error GoTo Error_Handling</SPAN>
 
  Application.ScreenUpdating = False</SPAN>
 
  Set wbBook = ThisWorkbook</SPAN>
 
  'Copy the worksheet to a new workbook.</SPAN>
  Worksheets("MissingShippingInfo").Copy</SPAN>
     
      'Retrieve the worksheet's name.</SPAN>
      stFileName = Worksheets("MissingShippingInfo").Name</SPAN>
   
 
    'Create the full path and name of the workbook.</SPAN>
    stAttachment = stPath & "\" & stFileName & ".xls"</SPAN>
 
    'Save and close the temporarily workbook.</SPAN>
    With ActiveWorkbook</SPAN>
      .SaveAs stAttachment</SPAN>
      .Close</SPAN>
    End With</SPAN>
 
    'Retrieve the list of recipients.</SPAN>
    With wsSheet</SPAN>
      lnLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row</SPAN>
      vaRecipients = .Range("L2:L" & lnLastRow).Value</SPAN>
    End With</SPAN>
 
    'Instantiate the Lotus Notes COM's Objects.</SPAN>
    Set noSession = CreateObject("Notes.NotesSession")</SPAN>
    Set noDatabase = noSession.GETDATABASE("", "")</SPAN>
 
    'If Lotus Notes is not open then open the mail-part of it.</SPAN>
    If noDatabase.IsOpen = False Then noDatabase.OPENMAIL</SPAN>
 
    'Create the e-mail and add the attachment.</SPAN>
    Set noDocument = noDatabase.CreateDocument</SPAN>
    Set noAttachment = noDocument.CreateRichTextItem("stAttachment")</SPAN>
    Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)</SPAN>
 
    'Add values to the created e-mail main properties.</SPAN>
    With noDocument</SPAN>
      .Form = "Memo"</SPAN>
      .SendTo = vaRecipients</SPAN>
      .Subject = stSubject</SPAN>
      .Body = vaMsg</SPAN>
      .SaveMessageOnSend = True</SPAN>
      .PostedDate = Now()</SPAN>
      .Send 0, vaRecipients</SPAN>
    End With</SPAN>
    'Delete the temporarily workbook.</SPAN>
    Kill stAttachment</SPAN>
 
 
  MsgBox ("The e-mails have successfully been created and distributed."), vbInformation</SPAN>
 
ExitSub:</SPAN>
  'Release objects from memory.</SPAN>
  Set noEmbedObject = Nothing</SPAN>
  Set noAttachment = Nothing</SPAN>
  Set noDocument = Nothing</SPAN>
  Set noDatabase = Nothing</SPAN>
  Set noSession = Nothing</SPAN>
 
  Exit Sub</SPAN>
 
Error_Handling:</SPAN>
 
  MsgBox "Error number: " & Err.Number & vbNewLine & _</SPAN>
      "Description: " & Err.Description, vbOKOnly</SPAN>
  Resume ExitSub</SPAN>
End Sub</SPAN>
Now whenever I attempt to run this macro, I receive the following error:
Run-time error '1004':
Application-defined or object-defined error

As for the sheet, here is the header row and the first row of data (types):
Shortage
Plt
Part Number Short
Config
Delivery Date
Carrier
Waybill
Transport Mode
Vendor
AC Short
PO Req Nbr
Buyer User Id
Gen
Gen
Gen
Gen
Date
Gen
Num
Gen
Gen
Gen
Num
Gen

<TBODY>
</TBODY>

I stepped through the code, and it appears to break in the Shortage_Macro during the first Print Setup. I have attempted to just run the Shortage_Macro and omitt the Send_Sheets_Notes_Email</SPAN></SPAN> and I receive the same error. Again, the Shortage_Macro ran just fine yesterday. Sorry for writing a short novel, but I did not want to waste anyones time by having them ask questions due to a lack of information.
 

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,930
Do you mean the error is on : ActiveSheet.PageSetup.PrintArea = Range("A1").CurrentRegion.Address</SPAN>
 

ohiojarhead

New Member
Joined
Jan 23, 2014
Messages
28
The error pops up after I move to this line when stepping through the code:
Code:
.LeftMargin = Application.InchesToPoints(0.7)</SPAN>
 

ohiojarhead

New Member
Joined
Jan 23, 2014
Messages
28
I shut my computer down and restarted it in hopes that that may fix the problem. No luck.
 

ohiojarhead

New Member
Joined
Jan 23, 2014
Messages
28
I have literally done nothing to the above referenced code. I attempted to play with it again, and the Shortage_Code now works. The problem is now the second piece (Send_Sheets_Notes_Email). I stepped through the code and discovered I did not set wsSheet. That has now been taken care of with the below code. The problem I am having is that it runs all the way through, but it never creates an email. I do not receive any errors. Any idea on what is wrong?
Code:
Public Sub Send_Sheets_Notes_Email()</SPAN>
 
  'Notes parameter for attaching the Excel files.</SPAN>
  Const EMBED_ATTACHMENT As Long = 1454</SPAN>
 
  'A folder to temporarily store the created Excel files in.</SPAN>
  Const stPath As String = "c:\temp"</SPAN>
 
  'The subject for the outgoing e-mails.</SPAN>
  Const stSubject As String = "Shortage Report - Missing Shipping Data"</SPAN>
 
  'The message in the bodies of the outgoing e-mails.</SPAN>
  Const vaMsg As Variant = "Please review the attached spreadsheet for the missing data and then update the shortage app." & vbCrLf & _</SPAN>
      "http://www.google.com" & vbCrLf & _</SPAN>
      "" & vbCrLf & _</SPAN>
      "" & vbCrLf & _</SPAN>
      "Respectfully," & vbCrLf & _</SPAN>
      "Name"</SPAN>
 
  'Variable that holds the list of recipients for each worksheet.</SPAN>
  Dim vaRecipients As Variant</SPAN>
 
  'Variable which holds each worksheet's name.</SPAN>
  Dim stFileName As String</SPAN>
 
  'Variables for Notes.</SPAN>
  Dim noSession As Object</SPAN>
  Dim noDatabase As Object</SPAN>
  Dim noDocument As Object</SPAN>
  Dim noEmbedObject As Object</SPAN>
  Dim noAttachment As Object</SPAN>
  Dim stAttachment As String</SPAN>
 
  'Variables for Excel.</SPAN>
  Dim wbBook As Workbook</SPAN>
  Dim wsSheet As Worksheet</SPAN>
  Dim lnLastRow As Long</SPAN>
  Set wsSheet = Worksheets("MissingShippingInfo")</SPAN>
  On Error GoTo Error_Handling</SPAN>
 
  Application.ScreenUpdating = False</SPAN>
 
  Set wbBook = ThisWorkbook</SPAN>
 
  'Copy the worksheet to a new workbook.</SPAN>
  Worksheets("MissingShippingInfo").Copy</SPAN>
     
      'Retrieve the worksheet's name.</SPAN>
      stFileName = Worksheets("MissingShippingInfo").Name</SPAN>
   
 
    'Create the full path and name of the workbook.</SPAN>
    stAttachment = stPath & "\" & stFileName & ".xls"</SPAN>
 
    'Save and close the temporarily workbook.</SPAN>
    With ActiveWorkbook</SPAN>
      .SaveAs stAttachment</SPAN>
      .Close</SPAN>
    End With</SPAN>
 
    'Retrieve the list of recipients.</SPAN>
    With wsSheet</SPAN>
      lnLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row</SPAN>
      vaRecipients = .Range("L2:L" & lnLastRow).Value</SPAN>
    End With</SPAN>
 
    'Instantiate the Lotus Notes COM's Objects.</SPAN>
    Set noSession = CreateObject("Notes.NotesSession")</SPAN>
    Set noDatabase = noSession.GETDATABASE("", "")</SPAN>
 
    'If Lotus Notes is not open then open the mail-part of it.</SPAN>
    If noDatabase.IsOpen = False Then noDatabase.OPENMAIL</SPAN>
 
    'Create the e-mail and add the attachment.</SPAN>
    Set noDocument = noDatabase.CreateDocument</SPAN>
    Set noAttachment = noDocument.CreateRichTextItem("stAttachment")</SPAN>
    Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)</SPAN>
 
    'Add values to the created e-mail main properties.</SPAN>
    With noDocument</SPAN>
      .Form = "Memo"</SPAN>
      .SendTo = vaRecipients</SPAN>
      .Subject = stSubject</SPAN>
      .Body = vaMsg</SPAN>
      .SaveMessageOnSend = True</SPAN>
      .PostedDate = Now()</SPAN>
      .Send 0, vaRecipients</SPAN>
    End With</SPAN>
    'Delete the temporarily workbook.</SPAN>
    Kill stAttachment</SPAN>
 
 
  MsgBox ("The e-mails have successfully been created and distributed."), vbInformation</SPAN>
 
ExitSub:</SPAN>
  'Release objects from memory.</SPAN>
  Set noEmbedObject = Nothing</SPAN>
  Set noAttachment = Nothing</SPAN>
  Set noDocument = Nothing</SPAN>
  Set noDatabase = Nothing</SPAN>
  Set noSession = Nothing</SPAN>
 
  Exit Sub</SPAN>
 
Error_Handling:</SPAN>
 
  MsgBox "Error number: " & Err.Number & vbNewLine & _</SPAN>
      "Description: " & Err.Description, vbOKOnly</SPAN>
 
  Resume ExitSub</SPAN>
End Sub</SPAN>
 
Last edited by a moderator:

Watch MrExcel Video

Forum statistics

Threads
1,118,076
Messages
5,570,066
Members
412,310
Latest member
mark884
Top