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.
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Do you mean the error is on : ActiveSheet.PageSetup.PrintArea = Range("A1").CurrentRegion.Address</SPAN>
 
Upvote 0
The error pops up after I move to this line when stepping through the code:
Code:
.LeftMargin = Application.InchesToPoints(0.7)</SPAN>
 
Upvote 0
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:
Upvote 0

Forum statistics

Threads
1,214,653
Messages
6,120,750
Members
448,989
Latest member
mariah3

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