VBA: Retain Column Width when Emailing as Attachment

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
146
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
I found this great script to email as an attachment, however, it does not retain the column width and it's so ugly and illegible. How do I fix it?

VBA Code:
Sub SendRange()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim Ws As Worksheet
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim WorkRng As Range
xTitleId = "SampleFile"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Wb = Application.ActiveWorkbook
Wb.Worksheets.Add
Set Ws = Application.ActiveSheet
WorkRng.Copy Ws.Cells(1, 1)
Ws.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
    xFile = ".xlsx"
    xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
    If Wb2.HasVBProject Then
        xFile = ".xlsm"
        xFormat = xlOpenXMLWorkbookMacroEnabled
    Else
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    End If
Case Excel8:
    xFile = ".xls"
    xFormat = Excel8
Case xlExcel12:
    xFile = ".xlsb"
    xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Now, "dd-mmm-yyyy")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
    .To = "email@email.com"
    .CC = ""
    .BCC = ""
    .Subject = "example"
    .Body = "hello, please check and read this document. "
    .Attachments.Add Wb2.FullName
    .Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I thought I could just add something like this in there, but it didn't work and just threw me errors:
VBA Code:
("Sheet1").Range ("A1:E1").Columns.AutoFit.
 

Some videos you may like

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
I think that if you replace this part
VBA Code:
Wb.Worksheets.Add
Set Ws = Application.ActiveSheet
WorkRng.Copy Ws.Cells(1, 1)
Ws.Copy
Set Wb2 = Application.ActiveWorkbook

by the below part your columns are being adjusted.
VBA Code:
Set Ws = Application.Workbooks.Add.Worksheets(1)
WorkRng.Copy Ws.Cells(1, 1)
Ws.UsedRange.Columns.AutoFit
Set Wb2 = Ws.Parent
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
146
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
I think that if you replace this part
VBA Code:
Wb.Worksheets.Add
Set Ws = Application.ActiveSheet
WorkRng.Copy Ws.Cells(1, 1)
Ws.Copy
Set Wb2 = Application.ActiveWorkbook

by the below part your columns are being adjusted.
VBA Code:
Set Ws = Application.Workbooks.Add.Worksheets(1)
WorkRng.Copy Ws.Cells(1, 1)
Ws.UsedRange.Columns.AutoFit
Set Wb2 = Ws.Parent

GWteB

Thank you. I'll give that a go.

Do you know how to select Visible cells only? It currently includes all my hidden rows too.
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
146
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
I revised this to include a range.
Also attempted to change it to Sheetname instead of Workbook name.
I would like to add font size.
Not sure where to fix the "Runtime error 9".
Where did I go wrong now?:(

VBA Code:
Subscript out of range

Sub SendRange()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim Ws As Worksheet
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim WorkRng As Range
xTitleId = "SampleFile"
Set WorkRng = Worksheets("SampleFile").Range("$A1:$K1000").SpecialCells(xlCellTypeVisible) '<====Is this correct to only send Visible Cells?

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Wb = Application.ActiveWorkbook

Set Ws = Application.Workbooks.Add.Worksheets(1)
WorkRng.Copy Ws.Cells(1, 1)
Ws.UsedRange.Columns.AutoFit
Set Wb2 = Ws.Parent

Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
    xFile = ".xlsx"
    xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
    If Wb2.HasVBProject Then
        xFile = ".xlsm"
        xFormat = xlOpenXMLWorkbookMacroEnabled
    Else
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    End If
Case Excel8:
    xFile = ".xls"
    xFormat = Excel8
Case xlExcel12:
    xFile = ".xlsb"
    xFormat = xlExcel12

End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Now, "dd-mmm-yyyy")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs ActiveSheet.Name & Date, FileFormat:=xFormat '<========How do I change this to Sheetname and not the current WB name, as there are multiple sheets?

With OutlookMail
    .To = "email@email.com"
    .CC = ""
    .BCC = ""
    .subject = "example"
    .body = "hello, please check and read this document."
    .Attachments.Add Wb2.FullName
    .Display
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
attempted to change it to Sheetname instead of Workbook name.
The code below takes that into account. It uses the name of the source worksheet from which the data is copied.

Not sure where to fix the "Runtime error 9".
I am not getting a run-time error.
This error ("subscript out of range") could have been caused because the specified worksheet could not be found. In your original code, the worksheet Worksheets("SampleFile") was not fully qualified. In such a situation, Excel expects to find that particular worksheet in the active workbook. If not found, this run-time error occurs. The code below assumes that this worksheet is in the same workbook where this code is located.

I would like to add font size.
No idea what you mean by this.


VBA Code:
Sub SendRange_r2()
    Dim xFile As String
    Dim xFormat As Long
    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim Ws As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim WorkRng As Range

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False

        Set Wb = .ThisWorkbook
        Set WorkRng = Wb.Worksheets("SampleFile").Range("$A1:$K1000").SpecialCells(xlCellTypeVisible)

        Set Ws = .Workbooks.Add.Worksheets(1)
        WorkRng.Copy Ws.Cells(1, 1)
        Ws.UsedRange.Columns.AutoFit
        Set Wb2 = Ws.Parent
        
        Select Case Wb.FileFormat
            Case xlOpenXMLWorkbook:
                xFile = ".xlsx"
                xFormat = xlOpenXMLWorkbook
            Case xlOpenXMLWorkbookMacroEnabled:
                If Wb2.HasVBProject Then
                    xFile = ".xlsm"
                    xFormat = xlOpenXMLWorkbookMacroEnabled
                Else
                    xFile = ".xlsx"
                    xFormat = xlOpenXMLWorkbook
                End If
            Case xlExcel8:
                xFile = ".xls"
                xFormat = xlExcel8
            Case xlExcel12:
                xFile = ".xlsb"
                xFormat = xlExcel12
        End Select
    
        FilePath = Environ("temp") & "\"
        FileName = WorkRng.Parent.Name & "_" & Date
        
        Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
        FileName = Wb2.FullName
        Wb2.Close
        
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = "email@email.com"
            .CC = ""
            .BCC = ""
            .Subject = "example"
            .body = "hello, please check and read this document."
            .Attachments.Add FileName
            .Display
        End With
        Kill FileName

        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub
 
Solution

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
146
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
The code below takes that into account. It uses the name of the source worksheet from which the data is copied.


I am not getting a run-time error.
This error ("subscript out of range") could have been caused because the specified worksheet could not be found. In your original code, the worksheet Worksheets("SampleFile") was not fully qualified. In such a situation, Excel expects to find that particular worksheet in the active workbook. If not found, this run-time error occurs. The code below assumes that this worksheet is in the same workbook where this code is located.


No idea what you mean by this.


VBA Code:
Sub SendRange_r2()
    Dim xFile As String
    Dim xFormat As Long
    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim Ws As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim WorkRng As Range

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False

        Set Wb = .ThisWorkbook
        Set WorkRng = Wb.Worksheets("SampleFile").Range("$A1:$K1000").SpecialCells(xlCellTypeVisible)

        Set Ws = .Workbooks.Add.Worksheets(1)
        WorkRng.Copy Ws.Cells(1, 1)
        Ws.UsedRange.Columns.AutoFit
        Set Wb2 = Ws.Parent
       
        Select Case Wb.FileFormat
            Case xlOpenXMLWorkbook:
                xFile = ".xlsx"
                xFormat = xlOpenXMLWorkbook
            Case xlOpenXMLWorkbookMacroEnabled:
                If Wb2.HasVBProject Then
                    xFile = ".xlsm"
                    xFormat = xlOpenXMLWorkbookMacroEnabled
                Else
                    xFile = ".xlsx"
                    xFormat = xlOpenXMLWorkbook
                End If
            Case xlExcel8:
                xFile = ".xls"
                xFormat = xlExcel8
            Case xlExcel12:
                xFile = ".xlsb"
                xFormat = xlExcel12
        End Select
   
        FilePath = Environ("temp") & "\"
        FileName = WorkRng.Parent.Name & "_" & Date
       
        Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
        FileName = Wb2.FullName
        Wb2.Close
       
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = "email@email.com"
            .CC = ""
            .BCC = ""
            .Subject = "example"
            .body = "hello, please check and read this document."
            .Attachments.Add FileName
            .Display
        End With
        Kill FileName

        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

GWteB Thanks for your explanations. Helps me to better understand.​

I was trying use a particular font and size it 10 pt font. I tried inserting some code I found off the internet, but it didn't work. Perhaps, I placed it incorrectly within this script. I don't think I need to declare anything?? So for example, if I want Arial 10pt font, where would I put that in this script?
 

Watch MrExcel Video

Forum statistics

Threads
1,127,331
Messages
5,624,061
Members
416,008
Latest member
PETE91

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
Top