Through Access VBA i'm opening the workbook and make visible=False, and then i do something and closing. But it is still running in the Taskmanager.
Dim ExcelApp As New Excel.Application
Dim ExcelBook As New Excel.Workbook
Dim rng As Excel.Range
Dim rngDefine As Excel.Range
Set ExcelBook = ExcelApp.Workbooks.Open("C\temp\find.xlsm")
ExcelApp.Visible = False
'//Do something
ExcelApp.Quit
ExcelBook.Close SaveChanges:=False
Set ExcelBook = Nothing
Set ExcelApp = Nothing
The commenters above are correct, your new workbook isn't associated with your ExcelApp instance. So at the end you're closing your new ExcelApp instance and closing the new workbook you created, but I think the new workbook is opening in a new instance of Excel... maybe, so you'd still see an orphaned Excel process in the task manager. I'd change your code to something more like this:
Dim ExcelApp as Excel.Application
Dim ExcelBook as Excel.Workbook
Dim rng As Excel.Range
Dim rngDefine As Excel.Range
Set ExcelApp = New Excel.Application
Set ExcelBook = ExcelApp.Workbooks.Open("C\temp\find.xlsm")
'ExcelApp.Visible = False You could maybe comment this out unless you use ".Activate" somewhere. It should be the default anyway.
...
'At the end:
ExcelApp.DisplayAlerts = False
ExcelBook.Close
ExcelApp.DisplayAlerts = True
ExcelApp.Quit
'If right before "End Sub" the next two lines are of arguable necesity, but likely good practice
Set ExcelBook = Nothing
Set ExcelApp = Nothing
Related
I'd like to export an email that contains many tables in HTML format.
Each table is something like this:
<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:100.0%;background:green">...</table>
I've added a New Rule in Outlook, so everytime I receive an email with 'specific word' in the Subject, the macro runs and saves all the tables from this email to a .xlsm file. The rule itself seems to work fine, but i'm having issues to make the macro work.
I've found many topics about exporting data from Outlook to Excel and I managed to copy email's TextBody using split (in rows), but it only worked with text, not with tables.
So I started searching the web for topics about exporting Tables, and I did find one. Although, it talks about importing Tables from Outlook using Excel VBA, not exactly what i'm trying to do. I tried to edit this code in order to work when running from Outlook, but it didn't work.
References:
Here's the code:
Option Explicit
Public Sub SalvaExcel()
'This macro writes an Outlook email's body to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
'Dim TextBody As String
'Dim iArr() As String
Dim eRow As Integer
Dim xlUp As Integer
Dim i As Long
Dim j As Long
xlUp = -4162
'set email to be saved
Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
Set olMail = olItems(olItems.Count)
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = olMail.HtmlBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'this slows down the macro, but helps during debugging
.ScreenUpdating = False 'reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("email")
'find first empty row
'eRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
'write table in excel
Debug.Print olEleColl(0)
For i = 0 To olEleColl(0).Rows.Length - 1
For j = 0 To olEleColl(0).Rows(i).Cells.Length - 1
.Range("A1").Offset(i, j).Value = olEleColl(0).Rows(i).Cells(j).innerText
Next j
Next i
'resize columns (DO NOT)
'.Columns("B:C").AutoFit
End With
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub
EDIT: There was a typo in the code, now it seems to be running, I can see that Excel opens then closes very quickly when I run the macro. However, when I open the workbook, the sheet where the tables were supposed to be is blank :(
EDIT2: I have tested the macro in an mail item where i inserted a random table and it worked, but it won't work with the tables in the mail that i showed.
EDIT3: I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!
Change that line to this instead
For i = 0 To olEleColl(0).Rows.Length - 1
(You spelled Length wrong)
I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!
Here's the code:
Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String
'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
'the most recent one
'Set olMail = olItems(olItems.Count)
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = item.HtmlBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'if True, this slows down the macro, but helps during debugging
.ScreenUpdating = False 'if False, this reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("email")
'which row to start
eRow = 1
posicao = "A" & eRow
'write each table in excel
For Each t In olEleColl
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
'ignore any problems with merged cells etc
On Error Resume Next
.Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
On Error GoTo 0
Next j
Next i
'define from which row the next table will be written
eRow = eRow + t.Rows.Length + 1
posicao = "A" & eRow
Next t
End With
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub
It exports all the tables from the last received email in the Outlook Inbox to an Excel file. It skips 1 row between one table and the next. Since it gets the most recent email and it runs from Outlook, it's useful to use in a New Rule, so it will be automatic, according to a defined criteria. I hope it helps other people!
edit: in order to run this macro in an Outlook Rule, it's necessary to give the following argument to the Sub, otherwise the macro won't be shown in the list of macros to be chosen for the Rule:
Public Sub SalvaExcel(item As Outlook.MailItem)
I have updated the code in this answer.
Thanks for sharing the code.
Have rectified your code to make it finally work ;)
Public Sub SalvaExcel()
'Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFoldersDefault As Outlook.Folders
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String
'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
'Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set newFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olFolder = newFolder.Folders("Projects").Folders("Management").Folders("Notifications")
Set olItems = olFolder.Items
olItems.Sort ("[ReceivedTime]")
'the most recent one
Set olMail = olItems(olItems.Count)
'MsgBox olMail
'MsgBox olMail.HTMLBody
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = olMail.HTMLBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "D:\OutlookEmails.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'if True, this slows down the macro, but helps during debugging
.ScreenUpdating = False 'if False, this reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("emails")
'which row to start
eRow = 1
posicao = "A" & eRow
'write each table in excel
For Each t In olEleColl
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
'ignore any problems with merged cells etc
On Error Resume Next
.Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
On Error GoTo 0
Next j
Next i
'define from which row the next table will be written
eRow = eRow + t.Rows.Length + 1
posicao = "A" & eRow
Next t
End With
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub
I am using this code to download certain outlook mail fields into access. This works well however the code is keep on downloading duplicate mails. Is there a way to check for existing records and download records which are not in the table? Your answers would help a lot in my project
Private Sub getml()
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim inbox As Outlook.MAPIFolder
Dim inboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Set db = CurrentDb
Set OlApp = CreateObject("Outlook.Application")
Set inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set rst= CurrentDb.OpenRecordset("mls")
Set inboxItems = inbox.Items
For Each Mailobject In inboxItems
With rst
.AddNew
!task= Mailobject.UserProperties.Find("taskID")
!tsktml= Mailobject.UserProperties.Find("timeline")
.Update
Mailobject.UnRead = False
End With
End If
Next
Set OlApp = Nothing
Set inbox = Nothing
Set inboxItems = Nothing
Set Mailobject = Nothi
End Sub
I am assuming that TaskID is a numeric unique identifier for tasks, not that familiar with Outlook objects. If so, you can use the following code to first check the task hasn't been imported already.
Private Sub getml()
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim inbox As Outlook.MAPIFolder
Dim inboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Set db = CurrentDb
Set OlApp = CreateObject("Outlook.Application")
Set inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set rst= CurrentDb.OpenRecordset("mls")
Set inboxItems = inbox.Items
For Each Mailobject In inboxItems
With rst
.FindFirst "task =""" & Mailobject.UserProperties.Find("taskID") & """"
If .NoMatch
.AddNew
!task= Mailobject.UserProperties.Find("taskID")
!tsktml= Mailobject.UserProperties.Find("timeline")
.Update
Mailobject.UnRead = False
End If
End With
End If
Next
Set OlApp = Nothing
Set inbox = Nothing
Set inboxItems = Nothing
Set Mailobject = Nothing
End Sub
I am running a few modules of code in access and am writing data into
Excel. When I write the first time, data gets written properly. But again
when I try, the new data is written on top of the old data. What should I do to
insert a new sheet?
My existing code is
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Dim objSht As Excel.Worksheet
Dim objRange As Excel.Range
Set objexcel = CreateObject("excel.Application")
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
Set objSht = wbexcel.Worksheets("Sheet1")
objSht.Activate
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets("Sheet1")
End If
I think that the following code should do what you want. It's very similar to yours, except it uses the return values from the .Add methods to get the objects you want.
Public Sub YourSub()
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
'This is a bad way of handling errors. We should'
'instead check for the file existing, having correct'
'permissions, and so on, and actually stop the process'
'if an unexpected error occurs.'
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbooks.Add()
End If
CopyToWorkbook wbexcel
EndSub
Private Sub CopyToWorkbook(objWorkbook As Excel.Workbook)
Dim newWorksheet As Excel.Worksheet
set newWorksheet = objWorkbook.Worksheets.Add()
'Copy stuff to the worksheet here'
End Sub
I'm trying to copy an excel worksheet to another workbook from within Access and keep getting the subscript out of range error. I've tried a few different things but can't seem to nail it. Any help would be appreciated. Using Access and Excel 2010 and my code is as follows:
Dim strTaxMonth As String
Dim strTaxYear As String
Dim strTabName As String
Dim objExcel As Excel.Application
Dim objWB As Workbook
Dim objWS As Worksheet
Dim strExcelFile0 As String
Dim strExcelFile1 As String
Dim strExcelFile2 As String
strTaxMonth = Forms!frm_PayrollTax_Report!ReportMonth
strTaxYear = Forms!frm_PayrollTax_Report!ReportYear
strTabName = strTaxMonth & strTaxYear & "_PTAX"
strExcelFile0 = "C:\File0.xlsm"
strExcelFile1 = "C:\File1.xlsx"
strExcelFile2 = "C:\File2.xlsm"
'Copy Worksheet to Yearly File
Set objExcel = New Excel.Application
objExcel.Visible = True
objExcel.DisplayAlerts = False
If Len(Dir(strExcelFile1)) > 0 Then Kill strExcelFile1
Set objWB = objExcel.Workbooks.Open(strExcelFile0)
objWB.Activate
Set objWS = objExcel.Sheets("PTAX")
objWS.Activate
objWS.Unprotect
objWS.Select
objWS.Name = strTabName
objWS.Range("A1:I16").Select
objWS.Range("A1:I16").Copy
objWS.Range("A1:I16").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
objWS.Range("B19:I28").Select
objWS.Range("B19:I28").Copy
objWS.Range("B19:I28").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
objWS.Protect
objWS.Select
objExcel.Workbooks.Open(strExcelFile0).Sheets(strTabName).Copy After:=objExcel.Workbooks.Open(strExcelFile2).Sheets("YTD PTAX")
objExcel.Workbooks(strExcelFile0).Activate
objExcel.ActiveWorkbook.SaveAs strExcelFile1
objExcel.ActiveWorkbook.Close False
objExcel.Quit
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing
End Sub
Just use this piece of code
Sub test()
Dim xlapp as New Excel.Application
Dim xlwkb as Workbook
Dim xlsht as Worksheet
Dim xlwkb2 as Workbook
Dim xlsht2 as Worksheet
xlapp.DisplayAlerts=False
'First workbook and Sheet
Set xlwkb=xlapp.Workbooks.Open(strExcelFile0)
Set xlsht=xlwkb.Worksheets(1)
'Second workbook and Sheet
Set xlwkb2=xlapp.Workbooks.Open(strExcelFile0)
Set xlsht2=xlwkb.Worksheets(1)
xlsht.Range("A1:B16").Copy Destination:=xlsht2.Range("A1")
Set xlsht=Nothing
xlwkb.Close
Set xlwkb=Nothing
xlwkb2.Saveas "C:\File.xls"
Set xlsht2=Nothing
xlwkb2.Close
xlapp.DisplayAlerts=True
Set xlapp=Nothing
xlapp.Quit
End Sub
I've adapted this code from somewhere else. At the click of a button on a form it's meant to tell me the number of non-empty rows in a given range of cells (C1:C500) on an Excel spreadsheet...
Sub ImportDataFromRange()
Dim excelapp As Excel.Application
Set excelapp = CreateObject("excel.application")
excelapp.Workbooks.Open (Application.CurrentProject.Path & "\MattExcelFile.xls")
Dim myrange As Range
Set myrange = excelapp.Sheets("Sheet1").Range("C1:C500")
Dim numberofrows As Integer
numberofrows = Excel.Application.WorksheetFunction.CountA(myrange)
MsgBox numberofrows
Debug.Print excelapp
excelapp.Quit
Set excelapp = Nothing
End Sub
Private Sub Command0_Click()
ImportDataFromRange
End Sub
On opening MS-Access and running this code via the button I created, it works correctly the first time, but not again after that. Closing and re-opening MS-Access resets the behaviour so it will again work properly the first time it's run after being opened, but then never never again.
On its first run, this is the (correct) data stored in the dimensions:
excelapp = "C:\Users\Matt\Desktop\MattExcelFile.xls"
numberofrows = 4
On subsequent runs, this is the (incorrect) data stored in the dimensions:
excelapp = "Microsoft Excel"
numberofrows = 500
Can someone give me a hand with the code here so I can run code multiple times within the same MS-Access session and get the correct data in the dimensions each time? Many thanks.
Just made a couple of changes to your code - I noted them for you - works for me.
As for the excelapp dimension I think it saying 'Microsoft Excel' is correct, if you were to print the wb.Name dimension you would get the workbook name. Not sure why it was giving different dimensions on subsequent runs for you, possibly because you weren't explicitly closing the workbook, but that's a guess.
Sub ImportDataFromRange()
Dim excelapp As Object
Set excelapp = CreateObject("excel.application")
' assign the workbook
Dim wb As Object
Set wb = excelapp.Workbooks.Open(Application.CurrentProject.Path & "\tbl_Order_Status.xls")
Dim numberofrows As Integer
' Call function slightly differently
numberofrows = excelapp.Application.counta(wb.worksheets("Sheet1").Range("C1:C500"))
' Close and release wb
wb.Close
Set wb = Nothing
MsgBox numberofrows
Debug.Print excelapp
excelapp.Quit
Set excelapp = Nothing
End Sub
I believe that your problem stems from the fact that you create your excelapp object variable but then you use a different reference (Excel.Application.WorksheetFunction instead of excelapp.WorksheetFunction) on the line that gets numberofrows.
The following (corrected) code works for me:
Sub ImportDataFromRange()
Dim excelapp As Excel.Application
Set excelapp = New Excel.Application
excelapp.Workbooks.Open (Application.CurrentProject.Path & "\MattExcelFile.xls")
Dim myrange As Range
Set myrange = excelapp.Sheets("Sheet1").Range("C1:C500")
Dim numberofrows As Integer
numberofrows = excelapp.WorksheetFunction.CountA(myrange)
MsgBox numberofrows
Debug.Print excelapp
Set myrange = Nothing
excelapp.Quit
Set excelapp = Nothing
End Sub
Private Sub Command0_Click()
ImportDataFromRange
End Sub