I want to export the last range and as PDF.
I am using the following code in a userform with checkboxes:
Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
The code is to determine which worksheets has to be exported as a pdf.
At the same time I'll have to fill in the map where the PDFs can be stored.
After that the code starts an Outlook item and stores the PDFs as attachment.
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
The second code is to determine which worksheets are to be exported on the basis of the checkboxes with value true.
Private Sub CommandButton2_Click()
Unload Me
End Sub
Please, replace all code in the used form module with the next one:
Option Explicit
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard 'export the range, not the sheet
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If .DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload Me
End Sub
Please, send some feedback after testing it.
Related
I'm trying to automate an emailing process with outlook.
So far my code enables to:
Send different attachments to different recipients
Send the same range of the excel sheet (ex: A1:B3) as an image in the email body to all the recipients
Personalized message
What I would like is to send different ranges to different recipients (like the attachments) for example:
Email 1: Range A1 B3
Email 2: Range A4:B7
Email 3: Range A8:B11
etc...
Is it possible to make it on loop or sth?
Sub Send_Files()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim MakeJPG As String
Dim PictureRange As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
MakeJPG = CopyRangeToJPG("Sheet1", "F31: J37")
If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/>" & "<br/>" & Range("B15") & " " & Range("C15") & " " & Range("D15") & "<p>" & Range("B16") & "<p>" & "<\p>" & "</p><img src=""cid:NamePicture.jpg"" width=550 height=150></html>" & "<p>" & "<\p>" & Range("B17") & .HTMLBody
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
Set the initial image range and then offset it after each email sent .
Set rngImage = sh.Range("F27:J28")
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
With the constant TEST = True this code should run without sending emails. If correct set TEST = False.
Option Explicit
Sub Send_Files()
Dim OutApp As Object, OutMail As Object
Dim ws As Worksheet, cell As Range, cellA, rngA As Range
Dim jpgFilename As String, filename As String, html As String
Dim rngImage As Range, sImage As String, n As Long
Const TEST = True ' set to False to use Outlook
Const IMG_NAME = "Image_"
Const IMG_RANGE = "F27:J28" ' first email
If Not TEST Then
Set OutApp = CreateObject("Outlook.Application")
End If
Set ws = Sheets("Sheet1")
Set rngImage = ws.Range(IMG_RANGE) ' first image
' scan column B for valid email addresses
For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rngA = cell.Offset(,1).Resize(, 24) ' C:Z attachments
If Application.WorksheetFunction.CountA(rngA) = 0 Then
' no attachments - do nothing
ElseIf cell.Value Like "?*#?*.?*" Then
sImage = IMG_NAME & rngImage.Row & ".jpg" ' unique image name for each email
jpgFilename = CopyRangeToJPG(rngImage, sImage)
' email body
html = "Bonjour " & cell.Offset(0, -1).Value & "," & "<br/><br/>" _
& ws.Range("B15") & " " & ws.Range("C15") & " " & ws.Range("D15") & _
"<p>" & ws.Range("B16") & "</p><br/>" & _
"<img src=""cid:" & sImage & """ width=550 height=150>" & _
"<br/>" & ws.Range("B17")
If TEST Then
MsgBox "Image: " & jpgFilename & vbLf & html, vbInformation, "To: " & cell.Value
'Debug.Print html
Else
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = cell.Value
.Subject = Range("B11") & Range("H13") & " - " & cell.Offset(0, 2)
.Attachments.Add jpgFilename, 1, 0
.HTMLBody = html & .HTMLBody
' add attachments
For Each cellA In rngA.SpecialCells(xlCellTypeConstants)
filename = Trim(cellA.Value)
If filename <> "" Then
If Dir(filename) <> "" Then ' check file exists
.Attachments.Add filename
Else
MsgBox "Could not attach : " & filename, vbExclamation, cell.Value
End If
End If
Next
End With
Set OutMail = Nothing
End If
' next image
Set rngImage = rngImage.Offset(rngImage.Rows.Count)
n = n + 1
End If
Next
Set OutApp = Nothing
MsgBox n & " emails sent", vbInformation
End Sub
Function CopyRangeToJPG(rngImage As Range, filename As String) As String
Dim ws As Worksheet, folder As String
Set ws = rngImage.Parent ' sheet
' check range
If rngImage Is Nothing Then
MsgBox "Sorry this is not a correct range"
CopyRangeToJPG = ""
Exit Function
End If
' create image file
folder = Environ$("temp") & Application.PathSeparator
rngImage.CopyPicture
With ws.ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height)
.Activate
.Chart.Paste
.Chart.Export folder & filename, "JPG"
End With
ws.ChartObjects(ws.ChartObjects.Count).Delete
' return status
CopyRangeToJPG = folder & filename
End Function
I would like to make exports based on the boxes I checked
therefore with a lot of help I build the following code
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False 'export the range, not the sheet
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If .DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload basicUserform
End Sub
the problem is when I run the code no attachments show up or can be found in the destination map I choose earlier.
I also put the file here so you can see for yourself.:
https://easyupload.io/ufnmvr
I appreciate your help and time!
Added a check for valid range of 27 or more rows otherwise lastRng.Offset(-26) will fail and because On Error Resume Next was not cancelled with On Error Goto 0 it won't raise an error.
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog
Dim xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object
Dim xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String
Dim rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
If UBound(xArrShetts) < 0 Then
MsgBox "No sheets selected", vbExclamation
Exit Sub
End If
' check sheets exist
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & _
xArrShetts(I), vbInformation
Exit Sub
End If
On Error GoTo 0
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & _
"Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if filename already exist
xYesorNo = MsgBox("If same name files exist in the destination folder," & _
"number suffix will be added to the file name automatically " & _
"to distinguish the duplicates " & vbCrLf & vbCrLf & _
"Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'determine the last cell in A:A
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)
If lastRng.Row < 27 Then
MsgBox "Incorrect Start Row " & lastRng.Row, _
vbCritical, "ERROR on " & xSht.Name
Exit Sub
End If
'create the range to be exported as pdf
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'export the range, not the sheet
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False
xArrShetts(I) = xStr
Else
' no file created
xArrShetts(I) = ""
End If
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
If Len(xArrShetts(I)) > 0 Then
.Attachments.Add xArrShetts(I)
End If
Next
.Display ' or ' Send
End With
End Sub
I have this chunk of code :
The macro that calls 2 other macros depending on the cell value is this :
Option Explicit
Function lastRow(col As Variant, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
Sub runMacros()
Dim vDat As Variant
Dim i As Long
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
vDat = .Range(.Cells(1, "G"), .Cells(lastRow("G"), "G"))
End With
For i = LBound(vDat) To UBound(vDat)
If vDat(i, 1) = "First" Then
Macro3
Macro1
ElseIf vDat(i, 1) = "Second" Then
Macro3
Macro2
End If
Next i
End Sub
The first macro that is being called is this(Macro3) - it just creates a new folder if it does not exist:
Sub Macro3()
Dim Path As String
Dim Folder As String
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
End If
End Sub
and then I have this macro:
Sub Macro1()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, SavePath As String, StrFileName As String, MailSubjectName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
SavePath = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" 'Name of the folder
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "RejectionLetterEmployee.docx" 'Name of the word file
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Rejection$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name") 'File name will be determined by this column name
MailSubjectName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
StrFileName = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" & StrName
With wdApp.ActiveDocument
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Save as WORD file(not needed at the moment)
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder where the excel sheet exists(not needed)
.SaveAs Filename:=SavePath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder that has been created by Path_Exists function
.Close SaveChanges:=False
' Set OutApp = CreateObject("Outlook.Application")
' Set OutMail = OutApp.CreateItem(0)
' On Error Resume Next
' With OutMail
' .To = ""
' .SentOnBehalfOfName = ""
' .CC = ""
' .BCC = ""
' .Subject = "ID" & " " & MailSubjectName & " " & StrName
' .BoDy = ""
' .Attachments.Add StrFileName & ".pdf"
' .Display
'.Send
' End With
' On Error GoTo 0
' Set OutMail = Nothing
' Set OutApp = Nothing
End With
' Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Macro1 and Macro2 are the same code but they use a different Word file to create the PDF - Macro1 runs if a cell in "G" column contains the string "first" and Macro2 runs if it contains "second".
The macros create a PDF file and sends it via Outlook.
The problem with Macro1 and Macro2 is that they have a For loop which runs through all rows which basically contradicts what I want to do based on a cell value.
I tried to tweak it a little but since im not familiar that much with VBA I couldnt make it run on the row based on the For loop that runMacros() executes when it calls the 2 other macros.
I only succeeded making it work only on the first row or the last row.
So my question is this : How would I fix Macro1 code to work on a row that runMacros() check.
For example : runMacros() is executed via button.
it checks if G2 cell contains either "first" or "second".
if it contains "first" it will run Macro3 and Macro1.
if it contains "second" it will run Macro3 and Macro2.
runMacros() will then go to the next row, check and execute the macros until it reaches an empty row.
currently Macro1 and Macro2 have a for loop which is wrong because if the G2 contains "first" and G3 contains "second" all the PDF files will be according to Macro2 because it just replaced what Macro1 did
I want Macro1 and Macro2 to follow the row that runMacros() is checking and only execute on that row.
How do I do that?
In answering your question in passing parameters, there are a couple ways to do this. In the first example, create your vDat variable as a Range, then loop over the range and pass a range parameter.
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Range
With wks
Set vDat = .Range("G1").Resize(lastRow("G"), 1)
End With
Dim i As Long
For i = 1 To vDat.Rows.Count
If vDat.Offset(i, 0).Value = "First" Then
Macro3 vDat.Rows(i)
Macro1 vDat.Rows(i)
ElseIf vDat.Offset(i, 0).Value = "Second" Then
Macro3 vDat.Rows(i)
Macro2 vDat.Rows(i)
End If
Next i
End Sub
Private Sub Macro1(ByRef theRow As Range)
Debug.Print "Macro1 row address = " & theRow.Address
End Sub
Private Sub Macro2(ByRef theRow As Range)
Debug.Print "Macro2 row address = " & theRow.Address
End Sub
Private Sub Macro3(ByRef theRow As Range)
Debug.Print "Macro3 row address = " & theRow.Address
End Sub
But you actually created vDat as an array, so you can just pass the value of that row in the array:
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Variant
With wks
vDat = .Range("G1").Resize(lastRow("G"), 1).Value
End With
Dim i As Long
For i = LBound(vDat, 1) To UBound(vDat, 1)
If vDat(i, 0) = "First" Then
Macro3 vDat(i, 0)
Macro1 vDat(i, 0)
ElseIf vDat(i, 0) = "Second" Then
Macro3 vDat(i, 0)
Macro2 vDat(i, 0)
End If
Next i
End Sub
Private Sub Macro1(ByVal theRowValue As Variant)
Debug.Print "Macro1 row value = " & theRowValue
End Sub
Private Sub Macro2(ByVal theRowValue As Variant)
Debug.Print "Macro2 row value = " & theRowValue
End Sub
Private Sub Macro3(ByVal theRowValue As Variant)
Debug.Print "Macro3 row value = " & theRowValue
End Sub
What is not clear in your code and question is how the row relates to the DataSource or how you are using it in Macro1 or Macro2. I would also suggest renaming your macros to something more descriptive to what action the macro is performing.
With MailMerge you can create a batch of documents from a datasource.
Using the Status column as a WHERE clause in the datasource SQL allows you to create the
documents with only 2 runs of the same subroutine using a parameter to apply the different template.
Option Explicit
Sub runMacros()
Dim Template1 As String, Template2 As String, Path As String, Folder As String
Template1 = ThisWorkbook.Path & "RejectionLetterEmployee.docx"
Template2 = ThisWorkbook.Path & "RejectionLetterEntrepreneur.docx"
' create path for documents
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir Path
End If
' create documents
CreateDocuments "First", Template1, Path
CreateDocuments "Second", Template2, Path
MsgBox "Ended"
End sub
Sub CreateDocuments(Status As String, Template As String, SavePath)
MsgBox "Running macro for Status = [" & Status & "] using " & Template & vbCrLf & _
" into Folder " & SavePath, vbInformation
Const StrNoChr As String = """*./\:?|"
' Paths and Filename
Dim strMMSrc As String, strMMDoc As String, strMMPath As String
Dim StrFileName As String, t0 As Single
t0 = Timer
' open template
Dim wdApp As New Word.Application, wdDoc As Word.Document, i As Integer, j As Integer
Dim strName, MailSubjectName
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
Set wdDoc = wdApp.Documents.Open( _
Filename:=Template, _
AddToRecentFiles:=False, _
ReadOnly:=True, _
Visible:=False)
strMMSrc = ThisWorkbook.FullName ' datasource name
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.OpenDataSource Name:=strMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=strMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=" SELECT * FROM `Rejection$` WHERE Status = '" & Status & "'"
' confirm to create docs
If vbNo = MsgBox(.DataSource.RecordCount & " documents will be created in " & SavePath & _
", continue ?", vbYesNo, "Confirm") Then
GoTo skip
End If
' create one doc for each record in datasource
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
strName = Trim(.DataFields("Name"))
MailSubjectName = Trim(.DataFields("ID"))
'Debug.Print "Raw", i, strName, MailSubjectName
If strName = "" Then Exit For
End With
' do merge
.Execute Pause:=False
' construct doc filename to save
' replace illegal characters
For j = 1 To Len(StrNoChr)
strName = Replace(strName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
Debug.Print "Cleaned ", i, strName, MailSubjectName
'Save to the folder that has been created by Path_Exists function
StrFileName = SavePath & strName
With wdApp.ActiveDocument
.SaveAs Filename:=SavePath & strName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
MsgBox i - 1 & " documents created in " & SavePath, vbInformation, "Completed in " & Int(Timer - t0) & " secs"
skip:
' cleanup
wdDoc.Close SaveChanges:=False
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
I'm trying change the below to actually instead asking the path it should save to pre-definied path based on static variable + dynamic variable from cell.
If the folder dosen't exist it should be created.
Cansomeone guide me how to change this as I'm not VBA guru and it I can't find right solution at all.
Sub Pdf_To_EMail()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String
Dim xlSht As Excel.Worksheet
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogSaveAs)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Zapisz jako plik PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display False
.To = "Email#Email.com"
.CC = ""
.Subject = "”
.Body = ":"
.Attachments.Add xFolder
If DisplayEmail = False Then
.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
</code>
This should Work:
Currently it will check for a Folder on Your Desktop and Activesheet.Range("B2"), But you can change both of them in the String Formation xFolder
Sub Pdf_To_EMail()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String
Dim xlSht As Excel.Worksheet
Set xSht = ActiveSheet
''''New Code to detect if folder Exists
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
xFolder = Environ("USERPROFILE") & "\Desktop\" & xSht.Range("B2").Value '''' Change you path and cell Range
If objFSO.FolderExists(xFolder) Then
'do nothing
Else
objFSO.CreateFolder (xFolder) '
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Zapisz jako plik PDF
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display False
.To = "Email#Email.com"
.CC = ""
.Subject = "”"
.Body = ":"
.Attachments.Add xFolder
If DisplayEmail = False Then
.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
I found some coding to send my worksheet in an email as a pdf (I forgot what website it was on, so thank you if you created it on here!). I have been asked if I can include an excel version of the file in the email, along with the current pdf file (some people need it to copy and paste into other reports). Below is my current VBA. I cannot figure out how to also attach the current Worksheet as an excel file into the email as an attachment.
Thanks for any help!
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Not sure for what the Title is
Title = Range("A1")
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = Format(Now(), "MM-dd-yyyy") & " File Name" & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.PageSetup.PaperSize = xlPaperLegal
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = "Email Name " & Format(Now(), "MM-dd-yyyy")
.To = "xxx" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "All," & vbLf & vbLf _
& "xxx." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
You could save a worksheet as pdf file and email it as an attachment using the below code:
Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub
For more information, please refer to this link:
How To Save A Worksheet As PDF File And Email It As An Attachment Through Outlook?
If you want to attach the current worksheet as an excel file into the email as an attachment, please refer to the below code:
Option Explicit
Sub EmailandSaveCellValue()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = "some1#someone.com"
Const MailCC = "some2#someone.com"
Const MailBCC = "some3#someone.com"
MailSub = "Please review " & Range("Subject")
MailTxt = "I have attached " & Range("Subject")
'************************************************* ********
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = Range("Subject") & " Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error Goto 0
WB.SaveAs FileName:="C:\" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.Cc = MailCC
.Bcc = MailBCC
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
For more information, please refer to this link:
Send Excel sheet as email attachment using worksheet data.