VBA: Retain Column Width when Emailing as Attachment

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
246
Office Version
  1. 365
  2. 2019
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.
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
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
 
Upvote 0
GWteB said:
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
Click to expand...

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.
 
Upvote 0
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
 
Upvote 0
NeoSez said:
attempted to change it to Sheetname instead of Workbook name.
Click to expand...
The code below takes that into account. It uses the name of the source worksheet from which the data is copied.

NeoSez said:
Not sure where to fix the "Runtime error 9".
Click to expand...
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.

NeoSez said:
I would like to add font size.
Click to expand...
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
 
Upvote 0
Solution
GWteB said:
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
Click to expand...

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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Can I use VBA based on Cell Validation?
Replies
4
Views
609
sdmcavoy
S
C
  • Question Question
Help with pasting specific table data in the same format to attach to email
Replies
0
Views
500
Callum_97
C
G
  • Question Question
How do I amend the below code to include multiple email recipients
Replies
1
Views
469
rollis13
rollis13
B
  • Question Question
Email code stopped working
Replies
5
Views
759
6StringJazzer
6StringJazzer
H
  • Question Question
Advanced Multi VBA - Creating multiple temporary files and attach them to one email on outlook
Replies
2
Views
263
Hayf13
H

Forum statistics

Threads
1,223,896
Messages
6,175,260
Members
452,627
Latest member
KitkatToby

Share this page

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