Hi All,
I am using the below VBA email code by Ron De Bruin and it works well,
my spredsheet contain pivot table and other data columns.
i want to convert the whole spreadsheet into normal data table.
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: Excel Automation - Ron de Bruin
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long
Dim msgSpace As String
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ActiveSheet
.UsedRange.Value = .UsedRange.Value
.Name = sh.Name & Format(Now, "dd-mmm-yy")
.Move
End With
Set wb = ActiveWorkbook
TempFileName = "úæøéí " & sh.Name
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I am using the below VBA email code by Ron De Bruin and it works well,
my spredsheet contain pivot table and other data columns.
i want to convert the whole spreadsheet into normal data table.
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: Excel Automation - Ron de Bruin
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long
Dim msgSpace As String
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ActiveSheet
.UsedRange.Value = .UsedRange.Value
.Name = sh.Name & Format(Now, "dd-mmm-yy")
.Move
End With
Set wb = ActiveWorkbook
TempFileName = "úæøéí " & sh.Name
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub