I have a workbook where I am building an automated e-mail but I want that e-mail to contain data that is stored in a second workbook. Please see my code below, I did change some variable names/data just for confidentiality so hopefully that doesn't make it too difficult to read.
Option Explicit
Sub Button1_Click()
Dim objExcel As Object
Dim wb1 As Workbook
Dim ws1 as Worksheet
Set objExcel = CreateObject("Excel.Application")
Set wb1 = objExcel.Workbooks.Open(ThisWorkbook.Path & "\wb1.xls")
Set ws1 = wbStoreList.Worksheets("Sheet1")
Dim filePaths As Variant
Dim msg As String
Dim i As Integer
Dim objApp As Object
Dim objMail As Object
Dim fileName As String
Dim emailAddress As String
Dim subject As String
Dim name As String
Dim otherName As String
Dim rowNumber As Range
Set objApp = CreateObject("Outlook.Application")
filePaths = Application.GetOpenFilename(MultiSelect:=True)
If (IsArray(filePaths)) Then
For i = LBound(filePaths) To UBound(filePaths)
Set objMail = objApp.CreateItem(olMailItem)
fileName = Dir(filePaths(i))
If (Len(fileName) = 8) Then
emailAddress = "email" & Mid(fileName, 1, 3) & "#emailaddress.ca"
ElseIf (Len(fileName) = 9) Then
emailAddress = "email" & Mid(fileName, 1, 4) & "#emailaddress.ca"
End If
subject = "Confidential"
With ws1
'On Error Resume Next
Set rowNumber = .Range(.Cells(8, 1), .Cells(8, 10000)).Find(What:="311", LookIn:=xlValues).Row
End With
MsgBox rowNumber
dataFound:
objMail.Recipients.Add emailAddress
objMail.subject = subject
objMail.Attachments.Add filePaths(i)
objMail.Body = name & ", " & "(" & otherName & ")" & vbNewLine & vbNewLine & "Please see attached file."
objMail.Display
Next i
Else
MsgBox "No files were selected"
End If
End Sub
The error is on the line with:
Set rowNumber = .Range(.Cells(8, 1), .Cells(8, 10000)).Find(What:="311", LookIn:=xlValues).Row
Not sure if you can directly get the row number like that because rowNumber is a Range (according to your dim statement). Give it a try and break it down into two lines:
Set rowNumber = .Range(.Cells(1, 8), .Cells(10000, 8)).Find(What:="311", LookIn:=xlValues)
and then
If Not rowNumber is Nothing then lngNumber = rowNumber.Row
Note that I am using a new variable which should be of type long.
Dim lngRowNumber as Long
By the way: in your case Integer would actually suffice over Long.
Related
I have this sheet called "Distribution" that contains the name of the project and the emails associated with the project. I am creating an automated email but need to include all the emails for that project.
I currently have the names hard coded in the .to like this:
.To = "ana.chiriboga#lgihomes.com; trey.williams#lgihomes.com; fik.mesheka#lgihomes.com"
But would like to know how I can use VBA code to match the value in a worksheet called "Loans" where the project name is in column F. I know that I can use ActiveSheet.Range("F" & ActiveCell.Row).Value to get the project name but how do I add the email address in worksheet "Distribution" that match the project name?
Well you could select it with a user-form like so:
This is the code I used in the user-form, I names the select button Engage because I couldn't use Select as it's a restricted name. Then CancelOP is the cancel button.
Option Explicit
Private Sub CancelOp_Click()
Unload Me
End Sub
Private Sub Engage_Click()
Dim I As Integer
For I = 0 To SelectionList.ListCount - 1
If SelectionList.Selected(I) = True Then
SelectedItem = (SelectionList.List(I))
End If
Next I
Unload Me
End Sub
I decided to store the selected project as a global variable, although I probably didn't have to: SelectedItem. And I decided to make the whole sub a string function so it can be used in the main sub as the list of emails.
Here is the whole function (I included the sub I used to test it):
Option Explicit
Public SelectedItem As String
Function Select_Project_Email_List() As String
Dim Distribution As Worksheet
Dim Dict As Scripting.Dictionary
Dim RG As Range
Dim CL As Range
Dim Arr
Dim EmailString As String
Dim I As Long
Dim sRow As Long
Dim lRow As Long
Set Distribution = ThisWorkbook.Worksheets("Distribution")
Set Dict = New Scripting.Dictionary
With Distribution
Set RG = .Range("A1", .Range("B" & Rows.Count).End(xlUp).Offset(1, 0))
For Each CL In RG.Columns(1).Cells
If CL.MergeCells Then
I = I + 1
Dict.Add I, CL.Value
End If
Next CL
ListSelector.SelectionList.List = Dict.Items
ListSelector.Show
Debug.Print SelectedItem
sRow = RG.Find(SelectedItem).Row + 1
lRow = RG.Find("", .Range("A" & sRow)).Row - 1
Debug.Print sRow
Debug.Print lRow
Set RG = .Range("A" & sRow, "B" & lRow)
Arr = RG
End With
EmailString = ""
For I = 1 To UBound(Arr, 1)
EmailString = EmailString & Arr(I, 2) & "; "
Next I
EmailString = Left(EmailString, Len(EmailString) - 2)
Select_Project_Email_List = EmailString
End Function
Sub TestEmailList()
Dim EmailList As String
EmailList = Select_Project_Email_List
Debug.Print EmailList
MsgBox Replace(EmailList, " ", vbCrLf), vbOKOnly, "EmailList"
End Sub
Example:
Option 2: No User Form, Activecell Method
Sub Select_Project_Email_List_ActiveCell()
Dim Distribution As Worksheet
Dim Loans As Worksheet
Dim Dict As Scripting.Dictionary
Dim RG As Range
Dim CL As Range
Dim Arr
Dim EmailString As String
Dim SelectedItemAC As String
Dim I As Long
Dim sRow As Long
Dim lRow As Long
Set Distribution = ThisWorkbook.Worksheets("Distribution")
Set Loans = ThisWorkbook.Worksheets("Loans")
Set Dict = New Scripting.Dictionary
With Distribution
Set RG = .Range("A1", .Range("B" & Rows.Count).End(xlUp).Offset(1, 0))
For Each CL In RG.Columns(1).Cells
If CL.MergeCells Then
I = I + 1
Dict.Add I, CL.Value
End If
Next CL
SelectedItemAC = ActiveCell.Value
Debug.Print SelectedItemAC
sRow = RG.Find(SelectedItemAC).Row + 1
lRow = RG.Find("", .Range("A" & sRow)).Row - 1
Debug.Print sRow
Debug.Print lRow
Set RG = .Range("A" & sRow, "B" & lRow)
Arr = RG
End With
EmailString = ""
For I = 1 To UBound(Arr, 1)
EmailString = EmailString & Arr(I, 2) & "; "
Next I
EmailString = Left(EmailString, Len(EmailString) - 2)
Call BuildEmail(EmailString)
End Sub
Sub BuildEmail(EmailString As String)
Dim objOutlook As Object
Dim objEmail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = EmailString
.CC = ""
.BCC = ""
.Subject = "Email Subject"
.Body = "Hello world"
.Display
'.Send
End With
End Sub
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I am trying find e-mail that matches body text and sender.
Each day I check if 300/400 emails were already sent.
I need to iterate through more than 4500 emails.
Sub Check()
Application.Calculation = xlManual
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Dim OutMail As Object
Dim Last As Long
Last = ThisWorkbook.Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set OutNameSpace = OutApp.GetNamespace("MAPI")
Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
Set OutItms = OutFolder.Items
Set numbers = ThisWorkbook().Sheets(2).Range(Cells(2, 2), Cells(Last, 2))
Dim numer As Range
For Each number In numbers
Z = 1
If numer = "" Then GoTo nastepny
For Each OutMail In OutFolder.Items
If InStr(1, OutMail.Body, number, vbTextCompare) <> 0 Then
If InStr(1, OutMail.Sender, "Sender Name", vbTextCompare) <> 0 Then
number.Offset(0, 7) = "Yes"
GoTo nastepny
End If
Else
number.Offset(0, 7) = "No"
End If
nastepny:
Next OutMail, number
Application.Calculation = xlAutomatic
End Sub
This code runs through all e-mails and checks if there is e-mail with correct number in body and correct sender. For more then 4500 e-mails it takes a lot of time to do it one by one.
With Restrict determine whether any item contains applicable text.
https://learn.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Check()
Application.Calculation = xlManual
' Late binding.
' Reference to Microsoft Outlook XX.X Object Library not required.
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutNameSpace = OutApp.GetNamespace("MAPI")
' Assumptions:
' 1 - Inne is the sender
' 2 - Applicable items from Inne in subfolder Inne
Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
Set OutItms = OutFolder.Items
Debug.Print " OutItms.Count.....: " & OutItms.Count
Dim wB As Workbook
Set wB = ThisWorkbook
Dim wS As Worksheet
Set wS = wB.Worksheets(2)
Dim Last As Long
Dim numbers As Range
With wS
'Entries in column 2
Last = .Cells(.Rows.Count, 2).End(xlUp).Row
Set numbers = .Range(.Cells(2, 2), .Cells(Last, 2))
End With
Dim numBer As Range
For Each numBer In numbers
If numBer <> "" Then
Dim strFilter As String
' https://learn.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & numBer & "%'"
Debug.Print strFilter
Dim numBerResults As Object
Set numBerResults = OutFolder.Items.Restrict(strFilter)
Debug.Print " numBerResults.Count.....: " & numBerResults.Count
If numBerResults.Count > 0 Then
numBer.Offset(0, 7) = "Yes"
Else
numBer.Offset(0, 7) = "No"
End If
End If
Next numBer
Application.Calculation = xlAutomatic
Debug.Print "Done."
End Sub
Could you advise please how to export emails from excel files?
I have an excel files with column called emails - this is a list of emails.
How can VBA script check every email from excel file in outlook and export emails with subject, data, sender from these excel file to new excel file or new sheet in current excel.
I have this script:
Const MACRO_NAME = "Export Messages to Excel (Rev 4)"
Sub ExportMessagesToExcelbyDate()
Dim olkLst As Object, _
olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String, _
strDateRange As String, _
arrTemp As Variant, _
datStart As Date, _
datEnd As Date
strFilename = InputBox("Enter a filename to save the exported messages to.", , MICRO_NAME)
If strFilename <> "" Then
strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
arrTemp = Split(strDateRange, "to")
datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
'Write messages to spreadsheet
Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkMsg In olkLst
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set olkLst = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MICRO_NAME
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
But this script export only selected folder in outlook.
What is the more important it should be exported from conversation history. For example in excel file there is mailbox YourMailbox#gmail.com. Script should find all conversation history and emails with this person and export information from emails. Information such as Subject, sender, date. Also script should check all list emails from excel file, not one.
Thanks for advices.
Application.ActiveExplorer.CurrentFolder will get current select folder, If you want to get all folder, you could refer to the below code:
Option Explicit
Sub repopulate3()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olparentfolder As Outlook.Folder
Dim olMail As Object
Dim eFolder As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long
'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")
Set olparentfolder = olNs.GetDefaultFolder(olFolderInbox)
'wb.Sheets("vlookup").range("A2:C500").ClearContents
'i think you want column E here, not L?
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row
ProcessFolder olparentfolder
ExitRoutine:
Set olparentfolder = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)
Dim olFolder As Outlook.Folder
Dim olMail As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long
'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row
For i = oParent.Items.Count To 1 Step -1
Debug.Print oParent
If TypeOf oParent.Items(i) Is MailItem Then
Set olMail = oParent.Items(i)
Debug.Print " " & olMail.Subject
Debug.Print " " & olMail.ReceivedTime
Debug.Print " " & olMail.SenderEmailAddress
Debug.Print
'For iCounter = 2 To lastrow
'If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
'With ws
' lrow = .range("A" & .Rows.count).End(xlUp).Row
' .range("C" & lrow + 1).Value = olMail.body
' .range("B" & lrow + 1).Value = olMail.ReceivedTime
' .range("A" & lrow + 1).Value = olMail.SenderEmailAddress
'End With
'End If
'Next iCounter
End If
Next i
If (oParent.Folders.Count > 0) Then
For Each olFolder In oParent.Folders
ProcessFolder olFolder
Next
End If
End Sub
For more information, Please refer to the below link:
VBA code to loop through every folder and subfolder in Outlook
My problem is when closing workbook2 I need to use code to automatically select No on a message box that pops up. This is how my code is laid out:
Workbook1 creates multiple files based on user input.
The loop in Workbook1 opens up Workbook2 and inputs data from Workbook1.
When the loop is done inputing data it closes workbook2 and a message box pops up with a Yes or No button on it.
User at this time should always select No.
Another window ask if the user would like to save and it should always be yes.
Loop continues until it has created all the files user has requested
I tried googling variations of my question but have not had much luck. Any help is much appreciated.
Dim JobName As String
Dim lngLoop As Long
Dim i As Integer
Dim Customer As String
Dim LastRow As Long
Dim iCus As Integer
Dim CompanyName As String
Dim d As Long
Dim strDir As Variant
Dim DIV As String
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As Workbook
Dim NewFileType As String
Dim NewFile As String
Dim QTR_NUM As String
Dim MFG As String
Dim Job As String
Dim visitdate As Variant
Dim visitdate_text As String
Dim Quote_Request As Worksheet
Dim QTR As Workbook
Dim QTRLOG As Workbook
Dim FORM As Workbook
Dim DCSProgram As Workbook
Dim ILast As Long
Dim j As Integer
Dim k As Integer
Dim CustomerIDNum As String
Dim QTRNUM As String
Dim FolderName As String
'Creates Quote For Each MFG
For j = 0 To QTRList.ListCount - 1
Set QTRLOG = Workbooks.Open("C:\QTR LOG.xlsm")
Set QTR = Workbooks.Open("C:\QTR.xlsx")
'CODE TO INPUT DATA FROM USERFORM NEW QTR
With DCSProgram.Sheets("MFG_DATA")
ILast = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = MFG Then
QTR.Sheets(1).Range("B7").Value = .Cells(i, 2).Value
QTR.Sheets(1).Range("B8").Value = .Cells(i, 3).Value
QTR.Sheets(1).Range("B9").Value = .Cells(i, 4).Value
QTR.Sheets(1).Range("B12").Value = .Cells(i, 5).Value
QTR.Sheets(1).Range("B13").Value = .Cells(i, 6).Value
QTR.Sheets(1).Range("B14").Value = .Cells(i, 7).Value
QTR.Sheets(1).Range("B15").Value = .Cells(i, 8).Value
End If: Next: End With
With QTRLOG.Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 2) = QTRList.List(j)
'.Cells(i, 3) = FORM.Sheets(1).Range("H11").Value
.Cells(i, 5) = JobName
.Cells(i, 8) = "OPEN"
.Cells(i, 9) = QTR.Sheets(1).Range("H9").Value
End If: Next: End With
QTRLOG.Save
QTRLOG.Close
QTR.SaveAs Filename:="C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS\" & JobName & "\" _
& " DCS QTR " & QTRList.List(j) & " " & JobName & " (" & CustomerIDNum & ") " & visitdate_text & " .xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
'Code To Close File After Creating It
QTR.Close
Next j
End If
Application.ScreenUpdating = True
Call Shell("explorer.exe" & " " & "C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS", vbNormalFocus)
Unload NewQTR
End Sub
When this code runs a msgbox appears from the workbook QTR. I dont want the user to have to click yes or no at this time. I want to automatically select No and continue on to the next file. This process is repeated for each MFG.
Code in QTR:
Application.ScreenUpdating = True
MSG1 = MsgBox("Are you ready to email to MFG?", vbYesNo, "EMAIL MFG")
If MSG1 = vbYes Then
'Code to create email and attached workbook as PDF
Else
Const kPath As String = "C:\"
Const kFile As String = "Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\9. PROGRAM FILES\1. QUOTE REQUEST\QUOTE REQUEST LOG.xlsm"
Dim TOTALFOB As Double
Dim TOTALWC As Double
Dim Wbk As Workbook
Dim INWBK As Workbook
Dim QTR_NUM As String
Dim ILast As Long
Dim i As Long
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim LR As Long
Dim TOTALTIME As Variant
Set INWBK = ThisWorkbook
With Sheets("QTR")
LR = .Range("I" & Rows.Count).End(xlUp).Row
TOTALFOB = WorksheetFunction.Sum(.Range("I23:I" & LR))
End With
TOTALWC = TOTALFOB + INWBK.Sheets("QTR").Range("D18").Value
QTR_NUM = INWBK.Sheets("QTR").Range("H7").Value
TOTALTIME = INWBK.Sheets("WS_LOG").Range("J3").Value
Rem Set Wbk in case it's open
On Error Resume Next
Set Wbk = Workbooks(kFile)
On Error GoTo 0
Rem Validate Wbk
If Wbk Is Nothing Then Set Wbk = Workbooks.Open(kPath & kFile)
With Workbooks("QUOTE REQUEST LOG.xlsm").Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 6) = TOTALFOB
.Cells(i, 7) = TOTALWC
.Cells(i, 10) = TOTALTIME
End If: Next: End With
Wbk.Save
Wbk.Close
End If
End Sub
If your problem is avoiding some Workbook_BeforeClose() event handler placed in "ThisWorkbook" code to be executed, then you must "enclose" the code lines that close the workbook like follows
Application.EnableEvents = False
' your code that closes the workbook
Application.EnableEvents = True
Exit Sub before end if is making the code exit earlier.
So remove the above mentioned one and check.