I have a workbook that contains sheets of price lists for different customers, and each week I have to email all the pricelists to the corresponding customers. This is a fairly time-consuming task and I have been trying to automate it with VBA. For the most part, I have succeeded by using Ron de Bruin's code but I have run into an issue that I can't seem to solve so I'm for hoping some insight as to where I've gone wrong.
As previously mentioned this workbook contains multiple, different, price sheets that all need to be sent to different customers. I have modified this code slightly to meet my needs (e.g. only coping visible cells, to include the email signature, etc...). One major change I made to this code is that I loop through a range that contains the recipients' addresses (which can be seen below).
The problem that I'm currently facing is that this code works for all but two sheets. It will create an email for the two problem sheets, but nothing in the range (A1:L85) will be pasted into the email - it just sends an email with no body besides my signature. What makes this worse (or more interesting) is that these two problem sheets occur in the "middle" of the worksheets. Let's say problem sheet 1 = PS_1 and problem sheet 2 = PS_2 it would be like this:
WS_1, WS_2, ..., WS_14, PS_1, WS_16, PS_2, WS_18, ..., WS_32
So I'm wondering why it's only messing up on these two sheets, and how to fix it.
I have included all my code below (except for RangetoHTML which is on Ron de Bruin's website, and a function to that gets the worksheet names):
Sub email()
' this is intended to speed up the code
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range 'this is the range of the price list
Dim erng As Range 'this is the range of email addresses
Dim cell As Range
Dim wsnames() As String 'worksheet names are stored in an array
Dim pricedate As String 'the week of prices the user provides (e.g. July 1st - July 7th)
Dim tsheets As Integer 'total sheets
'counting variables
Dim m As Integer
Dim n As Integer
Set OutApp = CreateObject("Outlook.Application")
'initializing variables
Set rng = Nothing
'initializing variables
n = 0
pricedate = InputBox("Enter the week the prices are for (e.g. July 10th - July 15th): ", "Week")
If pricedate = vbNullString Then Exit Sub 'if the user presses cancel it will stop the macro
tsheets = ActiveWorkbook.Worksheets.Count 'finds how many sheets are in the workbook to adjust the size of the array
ReDim wsnames(tsheets) 'resizes the size of the array
wsnames = storewsnames 'passing the sheet names to wsnames
For m = 1 To tsheets - 1
If wsnames(m) = "Atwood" Then Exit For 'looks for the index of worksheet "Atwood", and once it's found it exits the loop
Next m
For n = m To tsheets - 1 'sets n to the index of "Atwood"
If Sheets(wsnames(n)).Visible = True Then 'only will send emails to visible sheets
With Sheets(wsnames(n))
Set rng = .Range("A1:L85")
Set erng = .Range("M71:M85")
End With
On Error GoTo cleanup
For Each cell In erng 'searches the cells in the email addresses range
If cell.Value Like "?*#?*.?*" Then 'looks
'_for email addresses where the email addresses are saved
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.To = ""
.CC = ""
.BCC = cell.Value
.Subject = "CM Weekly Prices - " & wsnames(n)
.HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri> Hi, " & _
"<br><br>" & "Below are the prices for the week of " & pricedate & _
"." & RangetoHTML(rng) & "Thank you, </BODY><br>" & .HTMLBody
.Send
End With
On Error GoTo cleanup
Set OutMail = Nothing
End If
Next cell
End If
Next n
' this is intended to speed up the code
With Excel.Application
.ScreenUpdating = True
.Calculation = Excel.xlCalculationAutomatic
.EnableEvents = True
End With
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I'm very unfamiliar with using VBA to send an email so I have been heavily reliant on the code I have used and have tried to only make minor-ish changes.
If there is anything else you folks need, or something is unclear please let me know!
Related
I have code to extract all email attachments from specific email folder.
I want to change to extract email attachments starting from a date which I enter in a dialog box. I want to extract email attachments from emails received in the last seven days.
Sub Extract_emails()
Dim OlApp As Object
Dim OlMail As Object
Dim OlItems As Object
Dim Olfolder As Object
Dim J As Integer
Dim strFolder As String
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
Next J
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
I need to extract only xlsx attachments (vendor sends Excel and pdf documents) and to save them in folder. After I need to open saved Excel file and to copy data in base and to close saved xlsx. I don't know name of xlsx file (usually it is our company name and some numbers) but every report has sheets "shipped" from which I copy data in base. No one reads these emails that's why I tried with unread emails.
Code which works with F8 but not with F5.
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = OlApp.getnamespace("MAPI").Folders("Freight.Invoice#omega.com").Folders("Inbox")
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
If OlMail.UnRead = True Then
If OlMail.Attachments.Count > 0 Then
For J = 1 To OlMail.Attachments.Count
FilePath = strFolder & "\" & OlMail.Attachments.Item(J).FileName
OlMail.Attachments.Item(J).SaveAsFile FilePath
If Right(FilePath, 4) = "xlsx" Then
runit FilePath
For I = 1 To Worksheets.Count
If Worksheets(I).Name = "Shipped" Then
Worksheets("Shipped").Activate
Set wsCopy = Worksheets("Shipped")
Set wsDest = Workbooks("Extract
emails.xlsm").Worksheets("DATA")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count,
"B").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count,
"B").End(xlUp).Offset(1).Row
wsCopy.Range("B4:K" & lCopyLastRow).Copy _
wsDest.Range("B" & lDestLastRow)
Worksheets("Shipped").Activate
ActiveWorkbook.Close savechanges:=False
End If
Next
End If
Next J
End If
End If
Next
For Each OlMail In OlItems
If OlMail.UnRead = True Then
OlMail.UnRead = False
DoEvents
OlMail.Save
End If
Set OlApp = Nothing
Set OlMail = Nothing
Set OlItems = Nothing
Set Olfolder = Nothing
Next
MsgBox ("Done")
End Sub
Sub runit(FilePath As String)
Dim Shex As Object
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set Shex = CreateObject("Shell.Application")
Shex.Open (FilePath)
End Sub
This is a tutorial rather than a direct answer to your question. I cover everything you need to know. I believe you will find this approach more useful than “a run this code and it will work” answer. I hope I have explained everything adequately. Come back with questions if necessary.
You need to compare an email’s ReceivedTime against the oldest required date. You say you intend to enter the oldest required date and you also say you want the last seven days. There may be an alternative. Type the following commands (except the comments) in you Immediate Window.
? now() The current date and time
? datevalue(now()) The current date
? dateadd("d",-7,now()) Seven days before now
? dateadd("d",-7,datevalue(now())) Seven days ago
? dateadd("ww",-1,datevalue(now())) One week ago
Do any of these expressions give you the date you want? In DateAdd, “d” and “ww” are intervals with “d” meaning days and “ww” meaning weeks. There are other values such as “w” meaning weekdays. Experiment if one of these expressions gives you almost what you want.
Other possibilities include setting a category or a custom property when the attachments are saved.
If you have not done so already, open your workbook and the VBA Editor. Click [Tools] then [References…]. Is “Microsoft Outlook nn.n Object Library” near the top of the list and ticked? Note: “nn.n” depends on the version of Office you are using. If this library is not listed and ticked, scroll down until you find it and click the little box to tick it. This gives your workbook access to Outlook data items so you do not have to specify so many Objects.
Now create a new module and copy the code below to it. If you run macro Demo(), you will get output like this:
Oldest additions to Inbox
[14/12/2019 18:21:21] [28/12/2019 05:05:00] [08/01/2020 18:37:09] [28/03/2019 16:16:12] [21/03/2019 14:00:08]
[14/06/2018 21:02:34] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
Newest additions to Inbox
[18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40] [15/03/2020 19:43:16]
[14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23] [13/03/2020 08:46:58]
[12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38] [14/06/2018 21:02:34]
[21/03/2019 14:00:08] [28/03/2019 16:16:12] [08/01/2020 18:37:09] [28/12/2019 05:05:00] [14/12/2019 18:21:21]
Newest emails in Inbox
[20/03/2020 12:16:47] [20/03/2020 00:00:14] [19/03/2020 17:51:21] [19/03/2020 17:06:38] [19/03/2020 10:19:36]
[18/03/2020 16:21:25] [18/03/2020 01:43:37] [17/03/2020 11:14:29] [16/03/2020 20:39:58] [16/03/2020 16:48:40]
[15/03/2020 19:43:16] [14/03/2020 08:58:11] [14/03/2020 08:07:35] [14/03/2020 03:42:53] [13/03/2020 17:31:23]
[13/03/2020 08:46:58] [12/03/2020 00:07:53] [11/03/2020 13:43:33] [06/03/2020 17:03:50] [03/02/2020 09:29:38]
Oldest emails in Inbox
[14/06/2018 21:02:34] [21/03/2019 14:00:08] [28/03/2019 16:16:12] [14/12/2019 18:21:21] [28/12/2019 05:05:00]
[08/01/2020 18:37:09] [03/02/2020 09:29:38] [06/03/2020 17:03:50] [11/03/2020 13:43:33] [12/03/2020 00:07:53]
[13/03/2020 08:46:58] [13/03/2020 17:31:23] [14/03/2020 03:42:53] [14/03/2020 08:07:35] [14/03/2020 08:58:11]
[15/03/2020 19:43:16] [16/03/2020 16:48:40] [16/03/2020 20:39:58] [17/03/2020 11:14:29] [18/03/2020 01:43:37]
Things to note:
I have Dim OutApp As New Outlook.Application. The “New” says create the reference rather than just create a data item for a reference. This means I do not need GetObject or CreateObject. Outlook will only allow one occurrence of itself at a time so my “New” or your CreateObject will reference an existing occurrence or create a new one as necessary. I also have OutApp.Quit at the end. This closes Outlook whether or not it was already open. I don’t use Outlook while using Excel workbooks to access Outlook, so I want Outlook to be closed. If you care, use your Get or Create code but record which was successful, so you know if Quit is needed.
I have named my data item OutApp instead of olApp. Outlook uses the prefix “ol” for its constants, so I avoid this prefix in case my name matches one of Outlook’s.
I have used Session instead of GetNamespace("MAPI"). They are just different ways of achieving the same effect.
ItemsInbox is a “Collection”; what other languages call a “List”. A collection is like an array except you can add new entries before any existing entries, in the middle or after any existing entries. Any existing entries can be removed.
Outlook adds new emails at the end of the collection. So, if you read from first to last, the first email is the one that has been in Inbox longest first. If you read from last to first, the first email is the one that was added to Inbox most recently. This suggests that you can read from last to first and see the most recent emails first and you can stop when you reach an out-of-range email. However, if you move an old email from Inbox to another folder then move it back, it will not be returned to its old position; instead it will be added to the end.
In the macro below, I first list the ReceivedTime of twenty emails from first to last then from last to first. You may see that some are out of sequence.
I then list ReceivedTime of twenty emails after sorting by ReceivedTime in descending then ascending sequence.
Study the four blocks of dates. In particular, note the different sequences. I believe the code behind the third block of dates will be the most suitable for you.
I think I have covered everything but, as I said, come back will questions if necessary and I will repair any deficiencies.
Option Explicit
' Needs reference to "Microsoft Outlook n.nn Object Library"
' where n.nn depends on the version of Outlook you are using.
Sub Demo()
Dim FldrInbox As Outlook.Folder
Dim InxICrnt As Long
Dim InxIMax As Long
Dim ItemsInbox As Outlook.Items
Dim NumOnLine As Long
Dim OutApp As New Outlook.Application
Set FldrInbox = OutApp.Session.Folders("a.j.dallimore#xxxxxxx.com").Folders("Inbox")
Set ItemsInbox = FldrInbox.Items
If ItemsInbox.Count > 20 Then
InxIMax = 20
Else
InxIMax = ItemsInbox.Count
End If
Debug.Print "Oldest additions to Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Debug.Print "Newest additions to Inbox"
NumOnLine = 0
For InxICrnt = InxIMax To 1 Step -1
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", True
Debug.Print "Newest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
ItemsInbox.Sort "ReceivedTime", False
Debug.Print "Oldest emails in Inbox"
NumOnLine = 0
For InxICrnt = 1 To InxIMax
Debug.Print " [" & ItemsInbox(InxICrnt).ReceivedTime & "]";
NumOnLine = NumOnLine + 1
If NumOnLine = 5 Then
Debug.Print
NumOnLine = 0
End If
Next
Debug.Print
Set ItemsInbox = Nothing
OutApp.Quit
Set OutApp = Nothing
End Sub
Revised requirement
Every week or so, you receive an email from a vendor containing an invoice in both PDF and XLSX formats. An Outlook rule recognises that email and moves it to a dedicated folder. Your team is not interested in the PDF version. The XLSX workbook does not have a consistent name. However, it consistently contains a worksheet “Shipped” that contains data that would be useful to your team. At present, you will not attempt to process that data by macro but you would like it consolidated into your own workbook so it can be viewed conveniently by the team. At present, the desired format is:
Columns B to K of row 4+ of worksheet “Shipped” for week starting 1Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 8Mar20
: : : : :
Columns B to K of row 4+ of worksheet “Shipped” for week starting 15Mar20
: : : : :
Reviewed ideas on achieving requirement
If you had asked a few months ago, I would have suggested linking the macro to the rule with “Run a script”. Microsoft has decided that “Run a script” is dangerous and it is no longer available by default. There is online help which explains how to make “Run a script” available but I suggest you wait until you are more experienced before attempting this.
I would suggest a revised format for the consolidated data:
Data from email received 2Mar20 9:10
Entire contents of worksheet “Shipped”
Data from email received 9Mar20 9:30
Entire contents of worksheet “Shipped”
Data from email received 16Mar20 9:20
Entire contents of worksheet “Shipped”
The heading rows mean there is no possible confusion about where one week’s data ends and another starts. Including the heading rows from the worksheet and all columns means that if they add another column it will still be included in your consolidation and you will have a warning if they change the sequence.
The macro does not have to be in the same workbook as the data. I usually keep the macro and the data separate for this type of task. The data is updated regularly, but the macro is only updated occasionally. For example, I download my bank statements every month and merge them into a continuous statement running back years. I only change the macro when they change the format of the download.
You do not need code that recognises the email by, for example, testing the UnRead property because the email of interest will be the latest in the dedicated folder. There is a possibility that you will call the macro before the new email has arrived, so the macro looks at last week’s email. If it checks the latest header within the consolidated worksheet, it will know it has an old workbook and can exit without making changes.
The following is my suggestion. Do not worry if you do not know how to achieve some of my ideas because I do know how to.
You have two workbooks with names like “Consolidation Macros V02.xlsm” and “Consolidated Data V25.xlsx”. Whenever a new invoice arrives, you open the latest consolidation macros workbook and start the consolidate macro. It is possible to start macros automatically when a workbook is opened but I suggest we leave that for the moment. The macro opens the latest data workbook and notes the date of the most recent addition. It accesses Outlook, finds the latest invoice email and checks its date against the date of the most recent addition. Unless the date of the latest invoice email is later that the latest addition, the macro terminates. If the date is satisfactory, the macro finds the XLSX attachment and saves it to disc. It opens that workbook, checks for worksheet “Shipped” and adds its contents to the bottom of worksheet “Shipped” within the latest consolidated data worksheet and saves the workbook with the next version number.
You will have noticed that I have a version number for each workbook. During my working life I saw too many disasters because people did not save a new version whenever they updated a file. I can drop the version numbers if you do not want them.
Do you think the above matches your requirement?
I have finished testing the system I proposed in my original answer. It is not exactly the same, for reasons I will explain later, but it matches in all important details. I am posting it as new answer so there is no confusion.
To test it, I created some workbooks which I named Test1, Test2, Test3 and so on. Within each workbook I created a worksheet “Shipped”. Each of these worksheets had a different number of rows and columns. Each cell contained “T-R-C” where T was the test number, R was the row and C was the column. These values made it very easy to check that data was copied correctly from the attachments to the consolidated worksheet. After deleting most of the rows so the structure was visible, the result of consolidation was:
You can see that my code can combine all the rows and all the columns from as many emails as required. My emails are not a week apart but that is not important.
My recommendation is that you try my macro as it is. You can then discuss the appearance with your colleagues, and we can then discuss how to change my macro to match your exact requirements.
Create a new disc folder and within it create two new workbooks: one ordinary (xlsx) and one macro-enabled (xlsm).
Name the ordinary workbook “Consolidated Data.xlsx”. Within it, rename the default worksheet as “Shipped”.
The name of the macro-enabled workbook is unimportant as is the name of the worksheet. Within the VBA Editor, create three modules and name then "LibExcel", "LibOutlook" and "ModConsolidate". Naming modules is not essential but dividing macros up by purpose and naming modules for those purposes makes life much easier.
I will tell you to move the code below to one of these three modules.
Module "ModConsolidate" is for code I have written specifically for your requirement. Module "LibExcel" is for code from my library of Excel related routines. Module "LibOutlook" is for code from my library of Outlook related routines.
When I end a project, I look through it to see if there is any code I might wish to use again. If there is, I extract it and save it in "PERSONAL.XLSB" which I use as my library. Any macro saved in this workbook is available to all other workbooks. Don’t bother today but when you have some spare time look up how to create "PERSONAL.XLSB". When you have created it, move modules "LibExcel" and "LibOutlook" to it. In "LibExcel", I have routines to find the last used row and column of a worksheet and to check is a named worksheet exists. In "LibOutlook" I have routines for opening and closing an instance of Outlook from Excel.
When I start a project, I look through my library for routines that might be appropriate. If necessary, a routine will be enhanced to provide functionality that I had not needed before. The result is I have a library of useful functions that get more powerful, and larger, as I complete each project.
I said I would have version numbers on the workbook I created for you. Unfortunately, the macros that handle this and related functionality are too large to post to Stack Overflow.
This code should go in LibExcel:
' Routines useful with Excel
Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
ByRef ColLast As Long)
' Sets RowLast and ColLast to the last row and column with a value
' in worksheet Wsht
' The motivation for coding this routine was the discovery that Find by
' previous row found a cell formatted as Merge and Center but Find by
' previous column did not.
' I had known the Find would miss merged cells but this was new to me.
' Dec16 Coded
' 31Dec16 Corrected handling of UserRange
' 15Feb17 SpecialCells was giving a higher row number than Find for
' no reason I could determine. Added code to check for a
' value on rows and columns above those returned by Find
' 25Jun17 Found column with value about that found by Find
Dim ColCrnt As Long
Dim ColLastFind As Long
Dim ColLastOther As Long
Dim ColLastTemp As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim Rng As Range
Dim RowIncludesMerged As Boolean
Dim RowBot As Long
Dim RowCrnt As Long
Dim RowLastFind As Long
Dim RowLastOther As Long
Dim RowLastTemp As Long
Dim RowTop As Long
With Wsht
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
RowLastFind = 0
ColLastFind = 0
Else
RowLastFind = Rng.Row
ColLastFind = Rng.Column
End If
Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
If Rng Is Nothing Then
Else
If RowLastFind < Rng.Row Then
RowLastFind = Rng.Row
End If
If ColLastFind < Rng.Column Then
ColLastFind = Rng.Column
End If
End If
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
If Rng Is Nothing Then
RowLastOther = 0
ColLastOther = 0
Else
RowLastOther = Rng.Row
ColLastOther = Rng.Column
End If
Set Rng = .UsedRange
If Rng Is Nothing Then
Else
If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
RowLastOther = Rng.Row + Rng.Rows.Count - 1
End If
If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
ColLastOther = Rng.Column + Rng.Columns.Count - 1
End If
End If
If RowLastFind < RowLastOther Then
' Higher row found by SpecialCells or UserRange
Do While RowLastOther > RowLastFind
ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
Debug.Assert False
' Is this possible
' Row after RowLastFind has value
RowLastFind = RowLastOther
Exit Do
End If
RowLastOther = RowLastOther - 1
Loop
ElseIf RowLastFind > RowLastOther Then
Debug.Assert False
' Is this possible
End If
RowLast = RowLastFind
If ColLastFind < ColLastOther Then
' Higher column found by SpecialCells or UserRange
Do While ColLastOther > ColLastFind
RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
'Debug.Assert False
' Column after ColLastFind has value
' Possible causes:
' * Find does not recognise merged cells
' ' Find does not examine hidden cells
ColLastFind = ColLastOther
Exit Do
End If
ColLastOther = ColLastOther - 1
Loop
ElseIf ColLastFind > ColLastOther Then
Debug.Assert False
' Is this possible
End If
ColLast = ColLastFind
End With
End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean
' Returns True if Worksheet WshtName exists within
' * if Wbk Is Nothing the workbook containing the macros
' * else workbook Wbk
' 21Aug16 Coded by Tony Dallimore
' 14Feb17 Coded alternative routine that cycled through the existing worksheets
' matching their names against WshtName to check if use of "On Error Resume Next"
' was the faster option. I needed to call the routines 6,000,000 times each to
' get an adequate duration for comparison. This version took 33 seconds while
' the alternative took 75 seconds.
' 21Feb20 Added "As Boolean" to declaration. Do not understand how routine worked
' without it.
Dim WbkLocal As Workbook
Dim Wsht As Worksheet
If Wbk Is Nothing Then
Set WbkLocal = ThisWorkbook
Else
Set WbkLocal = Wbk
End If
Err.Clear
On Error Resume Next
Set Wsht = WbkLocal.Worksheets(WshtName)
On Error GoTo 0
If Wsht Is Nothing Then
WshtExists = False
Else
WshtExists = True
End If
End Function
This code should go in LibOutlook
' Routines useful with Outlook.
Option Explicit
Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)
' If Created is True, quit the current instance if Outlook.
If Created Then
OutApp.Quit
End If
Set OutApp = Nothing
End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application
' Return a reference to the Outlook Application.
' Set Created to True if the reference is to a new application and to
' False if the reference is to an existing application.
' If Nothing is returned, the routine has been unable to get or create a reference.
' Only one instance of Outlook can be running. CreateObject("Outlook.Application")
' will return a reference to the existing instance if one is already running or
' will start a new instance if one is not running. The disadvantage of using
' CreateObject, is the caller does not know if Outlook was running so does not know
' whether or not to quit Outlook when it has finished using Outlook. By setting
' Created, this routine allows the caller to only quit if this is appropriate.
Set OutAppGetCreate = Nothing
On Error Resume Next
Set OutAppGetCreate = GetObject(, "Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
On Error Resume Next
Set OutAppGetCreate = CreateObject("Outlook.Application")
On Error GoTo 0
If OutAppGetCreate Is Nothing Then
Call MsgBox("I am unable to access Outlook", vbOKOnly)
Exit Function
End If
Created = True
Else
Created = False
End If
End Function
This code should go in ModConsolidate:
Option Explicit
' * Need reference to "Microsoft Outlook nn.n Object Library"
' where nn.n depends on the version of Office being used.
' * Needs reference to "Microsoft Scripting Runtime"
Const HeaderForData As String = "Data from email received"
Const WbkConName As String = "Consolidated Data.xlsx"
Const WshtName As String = "Shipped" ' Also used for name of workbooks
Sub ConsolidateDataFromShippedWshts() ()
' Outlook used "ol" as a prefix for its constants. I do not use the same
' prefix to avoid a clash.
Dim OutApp As Outlook.Application
Dim OutAppCreated As Boolean
Dim ColConLast As Long ' Last column of worksheet "Shipped" in consolidated workbook
Dim ColSrcLast As Long ' Last column of worksheet "Shipped" in source workbook
Dim DateLatestExisting As Date ' Date of last block of data in consolidated workbook
Dim DateStr As String ' Date extracted from header row
Dim FldrShipped As Outlook.Folder ' Outlook Folder containing source emails
Dim InxA As Long ' Index into attachments
Dim InxI As Long ' Index into mail items
Dim InxW As Long ' Into into WbkSrcNames
Dim ItemsShipped As Items ' Items in source folder
Dim Path As String ' Disc folder containing workbooks
Dim Rng As Range ' Various uses
Dim RowConCrnt As Long ' Current row of worksheet "Shipped" in consolidated workbook
Dim RowConLast As Long ' Last row of worksheet "Shipped" in consolidated workbook
Dim RowSrcLast As Long ' Last row of worksheet "Shipped" in source workbook
Dim WbkCon As Workbook ' Consolidated workbook
Dim WbkMacros As Workbook ' This workbook
Dim WbkSrc As Workbook ' Workbook extracted from email
Dim WbkSrcName As String ' Name of workbook extracted from email
Dim WbkSrcNameDates As Collection ' Collection of the names and dates of workbooks extracted from emails
Dim WshtCon As Worksheet ' Worksheet "Shipped" in consolidated workbook
Dim WshtSrc As Worksheet ' Worksheet "Shipped" in source workbook
Application.ScreenUpdating = False
Set WbkMacros = ThisWorkbook
Path = WbkMacros.Path
' ### Change if you want a different name for consolidated workbook
Set WbkCon = Workbooks.Open(Path & "\" & WbkConName)
Set WshtCon = WbkCon.Worksheets(WshtName)
' Find last used row of consolidated worksheet
Call FindLastRowCol(WshtCon, RowConLast, ColConLast)
If RowConLast = 0 Then
' No data added yet
DateLatestExisting = 0
Else
' Search up for header for last block of data added
With WshtCon
Set Rng = .Columns(1).Find( _
What:=HeaderForData, After:=.Cells(RowConLast + 1, 1), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False)
If Rng Is Nothing Then
Debug.Assert False
' It should not be possible to be here. Either the worksheet is empty
' and RowColLast = 0 or one or more blocks of data, each with a header,
' have been added. It appears the worksheet is not as it should be.
DateLatestExisting = 0
Else
DateStr = Mid$(.Cells(Rng.Row, 1).Value, Len(HeaderForData) + 2)
If IsDate(DateStr) Then
DateLatestExisting = DateValue(DateStr) + TimeValue(DateStr)
Else
Debug.Assert False
' It should not be possible to be here. The text after HeaderForData
' should be a valid date. It appears the worksheet is not as it should be.
DateLatestExisting = 0
End If
End If
End With
End If
Set OutApp = OutAppGetCreate(OutAppCreated)
If OutApp Is Nothing Then
' OutAppGetCreated() failed. The user has already been told.
Exit Sub
End If
' ### Change to access folder where you store these emails
Set FldrShipped = OutApp.Session.Folders("MyName#MyIsp").Folders("Test")
' Create list of items in folder sorted by ReceivedTime
Set ItemsShipped = FldrShipped.Items
ItemsShipped.Sort "ReceivedTime", True
Set WbkSrcNameDates = New Collection
' Read items, newest first, until reach an item at or before DateLatestExisting
' Save xlsx attachment, if any, and record names in WbkSrcNames
For InxI = 1 To ItemsShipped.Count
If TypeName(ItemsShipped(InxI)) = "MailItem" Then
If ItemsShipped(InxI).ReceivedTime <= DateLatestExisting Then
' No more unprocessed emails
Exit For
End If
' Save Xlsx attachment, if any
For InxA = 1 To ItemsShipped(InxI).Attachments.Count
If LCase(Right$(ItemsShipped(InxI).Attachments(InxA).FileName, 5)) = ".xlsx" Then
' Have found required attachment. Save with name based on date received
WbkSrcName = WshtName & " " & Format(ItemsShipped(InxI).ReceivedTime, "yymmdd hhmmss") & ".xlsx"
ItemsShipped(InxI).Attachments(InxA).SaveAsFile Path & "\" & WbkSrcName
WbkSrcNameDates.Add VBA.Array(WbkSrcName, ItemsShipped(InxI).ReceivedTime)
Exit For
End If
Next
End If
Next
Call OutAppClose(OutApp, OutAppCreated)
If WbkSrcNameDates.Count = 0 Then
' No new emails with xlsx attachments
WbkCon.Close SaveChanges:=False
Call MsgBox("No new emails containing an xlsx attachment", vbOKOnly)
Set WshtCon = Nothing
Set WbkCon = Nothing
Set WbkMacros = Nothing
Exit Sub
End If
' WbkSrcNameDates contains the names and received dates of the new workbooks
' with the newest first.
' Extract names in reverse order (oldest first) and add contents of worksheet
' "Shipped" to bottom of worksheet "Shipped" of consolidated workbook
For InxW = WbkSrcNameDates.Count To 1 Step -1
Set WbkSrc = Workbooks.Open(Path & "\" & WbkSrcNameDates(InxW)(0))
If WshtExists(WbkSrc, WshtName) Then
' Worksheet "Shipped" exists
Set WshtSrc = WbkSrc.Worksheets(WshtName)
Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
RowConCrnt = RowConLast + 1 ' Advance to first free row
With WshtCon.Cells(RowConCrnt, 1)
.Value = HeaderForData & " " & Format(WbkSrcNameDates(InxW)(1), "d-mmm-yy h:mm:ss")
.Font.Bold = True
End With
RowConCrnt = RowConCrnt + 1
With WshtSrc
.Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast)).Copy _
Destination:=WshtCon.Cells(RowConCrnt, 1)
End With
RowConLast = RowConCrnt + RowSrcLast - 1
End If
WbkSrc.Close SaveChanges:=False
Next
' Position cursor to header for latest data
Application.ScreenUpdating = True
WshtCon.Activate
WshtCon.Cells(RowConLast - RowSrcLast, 1).Select
Application.Goto ActiveCell, True
WbkCon.Close SaveChanges:=True
Set WshtCon = Nothing
Set WbkCon = Nothing
Set WbkMacros = Nothing
End Sub
At the top of ModConsolidate, it says it needs references to "Microsoft Outlook nn.n Object Library", where nn.n depends on the version of Office being used, and "Microsoft Scripting Runtime". If you are unsure what that means, ask and I will add an explanation.
Line 173 of ModConsolidate is Set FldrShipped = OutApp.Session.Folders("MyName#MyIsp").Folders("Test"). This references the Outlook folder in which I placed the test emails. Replace my Outlook folder with the one holding these emails on your system. Place as many of these emails as you have in that folder.
Run macro ConsolidateDataFromShippedWshts(). This macro will:
Open workbook “Consolidated Data.xlsx”
Check worksheet “Shipped” and find that it is empty.
Open Outlook if not already open.
Access the Outlook folder and extract the workbook from every email because worksheet “Shipped” is empty. Workbooks will be saved with the name “Shipped yymmdd hhmmss.xlsx”. If worksheet “Shipped” had not been empty, it would only have extracted workbooks from the newer emails.
Close Outlook if it was not open.
Open each of the new workbooks in turn and add the contents of their worksheet “Shipped” to worksheet “Shipped” within “Consolidated Data.xlsx”.
I have tested macro ConsolidateDataFromShippedWshts() thoroughly but only with my fake workbooks and emails. It should work properly unless I have misunderstood the nature of your workbooks and emails. If something goes wrong, describe the problem to me and I will try to diagnose the cause.
If everything works as expected. Review “Consolidated Data.xlsx” and discuss it with your colleagues. While you are doing that, I will start adding more information about my macro to this answer.
"... to extract email attachments starting from date which I enter in dialog box (I want to extract email attachments just for emails which I received in last seven day not the whole folder)."
Option Explicit
Sub Extract_attachments_recent_emails()
' code for Excel
Dim olApp As Object
Dim olMail As Object
Dim olItems As Object
Dim olfolder As Object
Dim J As Long
Dim strFolder As String
Dim ageDays As Long
Dim strFilter As String
Dim resItems As Object
Set olApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.Application")
End If
strFolder = ThisWorkbook.Path & "\Extract"
Set Olfolder = olApp.GetNamespace("MAPI").Folders("MyEmailAddress").Folders("Inbox")
Set olItems = olfolder.items
' save time with hardcoded number
'ageDays = 7
' be flexible with InputBox
ageDays = InputBox("ageDays", "Input age of oldest mail in days", "7")
strFilter = "[ReceivedTime]>'" & Format(Date - ageDays, "DDDDD HH:NN") & "'"
Set resItems = olItems.Restrict(strFilter)
For Each olMail In resItems
If olMail.Attachments.Count > 0 Then
For J = 1 To olMail.Attachments.Count
OlMail.Attachments.Item(J).SaveAsFile strFolder & "\" & OlMail.Attachments.Item(J).Filename
Next J
End If
Set olMail = Nothing
Next
MsgBox ("Done")
End Sub
I have minimal experience coding.
I have code to read invoice numbers as range c in one workbook - W1 -
and return corresponding values relating to invoice fees and due dates from another workbook - W2. The code runs as intended.
I would like to use the same range c to search sent items in Outlook for subject lines containing the c values, and return to W1 the recipient's email address and name.
For example, an invoice number could be displayed "201x/xxxx", the subject of the email would read "Invoice from ABC Ltd - 201x/xxxx", the code would return to W1 the required data.
I have attempted to apply the Like function.
Below is the code as it stands;
Sub UpdateDunningLog()
'defining source and target workbooks
Dim w1 As Worksheet, w2 As Worksheet
'c will be the matched value (invoice number)
Dim c As Range, FR As Long
'defining debtor log
Dim strfilename As String: strfilename = "xyz.xlsx"
Dim DL As Workbook
Application.ScreenUpdating = False
'sets active worksheet to Dunning Log
Set w2 = ActiveWorkbook.Sheets("Sheet1")
'sets debtor log to open (in background)
Set DL = Workbooks.Open(Filename:=strfilename, UpdateLinks:=3)
Set w1 = DL.Worksheets("Data")
Application.ScreenUpdating = False
'c is invoice number, macro begins reading at A4
' and continues until there are no remaining rows
For Each c In w1.Range("A4", w1.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
'matches invoice nummbers from debtor log to Dunning Log
FR = Application.Match(c, w2.Columns("E"), 0)
On Error GoTo 0
'if there is a match, client name is extracted
If FR <> 0 Then w2.Range("D" & FR).Value = c.Offset(0, 3)
'if there is a match, invoice value is extracted
If FR <> 0 Then w2.Range("G" & FR).Value = c.Offset(0, 15)
'if there is a match, overdue days are extracted
If FR <> 0 Then w2.Range("H" & FR).Value = c.Offset(0, 41)
Next c 'loops through each invoice number
Application.ScreenUpdating = True
'closes debtor log, ensuring it stays in the background throughout the process
DL.Close savechanges:=False
Dim olApp As Outlook.Application
Dim Folder As Outlook.MAPIFolder
Dim olNS As Namespace
Dim i As Integer, j As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim olMail As Object
MailBoxName = "xyz#xyz.xyz"
Pst_Folder_Name = "Sent Items"
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Folder = olNS.GetDefaultFolder(olFolderSentMail)
i = 1
For Each olMail In Folder.Items
If olMail.Subject Like "*c*" Then _
w2.Range("A" & FR).Value = Folder.Items.Item(i).RecipientName
If olMail.Subject Like "*c*" Then _
w2.Range("B" & FR).Value = Folder.Items.Item(i).RecipientEmailAddress
On Error GoTo 0
i = i + 1
Next olMail
End Sub
This line olMail.Subject Like "*c*" is looking for emails that contain the letter C in the subject line. To extract the value from range object c:
Dim SearchFor As String
SearchFor = "*" & c.Value & "*"
If olMail.Subject Like SearchFor Then
In the example, I've used string concatenation to build the search pattern. I've used a separate variable, although you don't have to.
You mentioned that your code is growing in size and becoming muddled. This is a common problem. One way of staying on top is to break your code into a number of smaller units. Rough example:
' Code execution starts here.
Sub EntryPoint
Dim iNums As Range
Dim iNum As Range
Dim CurrentSubject As String
Set iNums = GetInvoiceNumbers()
For Each iNum In iNums
CurrentSubject = GetEmailSubject(iNum)
Next
End Sub
' Returns a list of invoice numbers.
Function GetInvoiceNumbers() As Range
' ...Code here...
End Function
' Checks Outlet mailbox.
Function GetEmailSubject(ByVal InvoiceNumber As String) As String
' ...Code here...
End Function
Make sure each sub/function has one, and only job. Give it a meaningful name and soon you'll be able to speed read your code while looking for the right place to make the next change.
Edit
Ok so I missed a few important details in the OPs code. This is my reworked answer:
I've added a new function that extracts email details for the current invoice.
' Checks the xyz mailbox for any items with the supplied
' invoice number in the sent items folder.
'
' InvoiceNumber Invoice to search for.
' RecipientNameCell Cell to write name to.
' RecipientEmailAddressCell Cell to write email address to.
Sub ExtractEmailDetails(ByVal InvoiceNumber As String, ByRef RecipientNameCell As Range, ByRef RecipientEmailAddressCell As Range)
Dim OlApp As Outlook.Application
Dim SentFolder As Outlook.MAPIFolder
Dim OlMail As Object
Set OlApp = New Outlook.Application
Set SentFolder = OlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
For Each OlMail In SentFolder.Items
' Ignore notes and other items that might be stored in the folder.
If TypeName(OlMail) = "MailItem" Then
If OlMail.Subject Like "*" & InvoiceNumber & "*" Then
RecipientNameCell.Value = OlMail.Recipients.Item(1).Name
RecipientEmailAddressCell = OlMail.Recipients.Item(1).Address
End If
End If
Next
End Sub
You can call this from the existing loop in your code:
For Each c In w1.Range("A4", w1.Range("A" & Rows.Count).End(xlUp)) 'c is invoice number, macro begins reading at A4 and continues until there are no remaining rows
FR = 0
On Error Resume Next
FR = Application.Match(c, w2.Columns("E"), 0) 'matches invoice nummbers from debtor log to Dunning Log
On Error GoTo 0
If FR <> 0 Then w2.Range("D" & FR).Value = c.Offset(0, 3) 'if there is a match, client name is extracted
If FR <> 0 Then w2.Range("G" & FR).Value = c.Offset(0, 15) 'if there is a match, invoice value is extracted
If FR <> 0 Then w2.Range("H" & FR).Value = c.Offset(0, 41) 'if there is a match, overdue days are extracted
' NEW LINE BELOW.
ExtractEmailDetails c.Value, w2.Range("A" & FR).Value, w2.Range("B" & FR).Value
Next c 'loops through each invoice number
ExtractEmailDetails is executed once for each matched invoice number. It checks the entire sent box. At the moment if it finds more than 1 match only the last name/address found is written to Excel. To change this you'd need to allow for more rows or columns. Also, an email could have multiple recipients. Here details are extracted for the first. You could extract them all, either into a long field or additional rows/columns.
Without the spreadsheets, I couldn't fully test the code. The new function may require a little tweaking ;).
I have many Excel objects are there embedded in a MS-Word Document.
I want to calculating the grand total: with summing the totals are there in the each specified excel object and return that grand total in the MS-Word document.
Macro holder is MS-Word Document's VBA module.
Means: I need to access to an specified embedded Excel object, form the MS-Word module, then perform it active, then assign to an object-variable by -For example:- ExcelApplication = GetObject(, "Excel.Application") statement. Then try to access its appropriated total values , by -For example:- Total = Range("Table1[[#Totals],[Amount]]").Value. Point is all tables Name are in the Excel objects is Table1 which contains the Amount Columns and the Total Row.
Note is in above Excel objects, The first row which contains the Table Header is Hided.
Example
Sample File
This document have extending daily.
I need a macro in the Normal.dotm Which calculating the grand total of all specified Excel object (specified with assigning a name to them or ...) and perform returning this value with Selection.TypeText Text:= where is selected in picture below: (at the end of document)
Why I insist to have embedded Excel object?
Because I have formula for calculating Column1: A, B, C, ....
Because I have a hided Data base Sheet for data validation Items
I have Formula in Amount column for multiplying the rates and the
amount of each item-unit which is in Data base sheet
In that case, try something along the lines of:
Sub TallyXLVals()
Application.ScreenUpdating = False
Dim Rng As Range, objOLE As Word.OLEFormat, objXL As Object
Dim i As Long, lRow As Long, sValA As Single, sValB As Single, sValC As Single
Const xlCellTypeLastCell As Long = 11
With ActiveDocument
.ActiveWindow.Visible = False
For i = .InlineShapes.Count To 1 Step -1
With .InlineShapes(i)
If Not .OLEFormat Is Nothing Then
If Split(.OLEFormat.ClassType, ".")(0) = "Excel" Then
Set Rng = .Range
Set objOLE = .OLEFormat
objOLE.Activate
Set objXL = objOLE.Object
With objXL.ActiveSheet
lRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
sValA = sValA + .Range("A" & lRow).Value
sValB = sValB + .Range("B" & lRow).Value
sValC = sValC + .Range("C" & lRow).Value
End With
objXL.Application.Undo
End If
End If
End With
Next
Call UpdateBookmark("BkMkA", Format(sValA, "$#,##0.00"))
Call UpdateBookmark("BkMkB", Format(sValB, "$#,##0.00"))
Call UpdateBookmark("BkMkC", Format(sValC, "$#,##0.00"))
.ActiveWindow.Visible = True
End With
Set objXL = Nothing: Set objOLE = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(StrBkMk As String, StrTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(StrBkMk) Then
Set BkMkRng = .Bookmarks(StrBkMk).Range
BkMkRng.Text = StrTxt
.Bookmarks.Add StrBkMk, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
where the locations you want the outputs to appear are bookmarked, with the names BkMkA, BkMkB, & BkMkC, respectively.
Note: Because you're activating embedded objects, there is unavoidable screen flicker.
Your own effort is insufficent. Here is code to start you off. The code will loop through all the InlineShapes in your Word document, select the first one which represents an Excel worksheet and opens that item for editing. It is the same action which you can recreate in the document by right-clicking on the embedded Excel table, selecting "Worksheet Object" and "Edit".
Private Sub OpenEmbeddedExcelInWord()
' 08 Jan 2018
Dim Shp As InlineShape
For Each Shp In ActiveDocument.InlineShapes
With Shp
If Shp.Type = wdInlineShapeEmbeddedOLEObject Then Exit For
End With
Next Shp
Shp.OLEFormat.Edit
End Sub
I have a worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub
I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar
I have in excess of 300 word documents that include word tables, and I have been trying to write a VBA script for excel to extract the information I need, and I am completely new to Visual Basic. I need to copy the file name to the first cell, and the following cells to contain the information I am trying to extract, followed by the next file name, looping on until all word documents have been searched and extracted. I have tried multiple different ways, but the closest code I can find is as follows. It works to pull part numbers, but not descriptions. It also pulls extraneous information that doesn't need to be there, but I can work around that information if it is a necessary hazard.
I have an example word file (replaced sensitive information with other information), but I am not sure how to attach the word document or jpegs of page 1 and 2 of the word document. I know it would be beneficial if you could see it, so please let me know how to get it on here or to you so you can see it.
So to re-iterate:
I need the file name in the first cell (A1)
I need a certain cell out of table 3 from a word document to excel
If at all possible, I need descriptions in column B (B2:B?) and
mixture of letters and numbers in column C (C2:C?), then on the next
line down, the next file name (A?), and continue to repeat. If you
have any ideas, or suggestions, please let me know. And if I can't
post the picture, or the actual sample document, I am willing to
email, or any other means necessary to get help on this.
Here is the code I have been trying to manipulate. I found it and it was for a first and last row of a form, and I tried to get it to work, for my purposes to no avail:
Sub GetTablesFromWord()
'this Excel file must be in
'the same folder with the Word
'document files that are to be'processed.
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim wTable As Word.Table
Dim wCell As Word.Cell
Dim basicPath As String
Dim fName As String
Dim myWS As Worksheet
Dim xlCell As Range
Dim lastRow As Long
Dim rCount As Long
Dim cCount As Long
Dim RLC As Long
Dim CLC As Long
basicPath = ThisWorkbook.Path & Application.PathSeparator
'change the sheet name as required
Set myWS = ThisWorkbook.Worksheets("Sheet1")
'clear any/all previous data on the sheet myWS.Cells.Clear
'"open" Word Set wApp = CreateObject("Word.Application")
'get first .doc file name in the folder
'with this Excel file
fName = Dir(basicPath & "*.doc*")
Do While fName <> ""
'this puts the filename into column A to
'help separate the table data in Excel
myWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
"FILE: [" & fName & "]"
'open the Word file
wApp.Documents.Open basicPath & fName
Set wDoc = wApp.Documents(1)
'if there is a table in the
'Word Document, work with it
If wDoc.Tables.Count > 0 Then
Set wTable = wDoc.Tables(3)
rCount = wTable.Rows.Count
cCount = wTable.Columns.Count
For RLC = 1 To rCount
lastRow = myWS.Range("A" & Rows.Count).End(xlUp).Row + 1
For CLC = 1 To cCount
'if there are merged cells in the
'Word table, an error will be
'generated - ignore the error,
'but also won't process the data
On Error Resume Next
Set wCell = wTable.Cell(RLC, CLC)
If Err <> 0 Then
Err.Clear
Else
If CLC = 1 Then
Set xlCell = myWS.Range("A" & lastRow)
xlCell = wCell
Else
Set xlCell = myWS.Range("B" & lastRow)
xlCell = wCell
End If
End If
On Error GoTo 0
Next
Next
Set wCell = Nothing
Set wTable = Nothing
End If ' end of wDoc.Tables.Count test
wDoc.Close False
Set wDoc = Nothing
fName = Dir()
' gets next .doc* filename in the folder
Loop wApp.Quit
Set wApp = Nothing
MsgBox "Task Completed"
End Sub
This code loops through all of the .docx files contained within a folder, extracts data into your spreadsheet, closes the word document, and moves onto the next document. The name of the word document gets extracted into Column A, and a value from within the 3rd table in the document is extracted into Column B. This should be a good starting point for you to build upon.
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub