Reopening recently closed instances of Excel - vba

If I use the below code to close all instances of Excel that are currently open what would I need to use to reopen all the instances of Excel that were just closed? I know I'll have to change the below to save a filepath somewhere but just not sure what the actual code should be.
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
wb.Save
wb.Close
Next
xl.Quit
Set xl = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub

This stores file paths of the workbooks to a text file. If you run this macro with False as the input, this will open all of the recently closed files. (Not tested)
Public Sub CloseAllExcel(Closing As Boolean)
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim strPath As String
strPath = "C:\path.txt"
If Close Then
Dim fso as Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile as Object
Set oFile = FSO.CreateTextFile(strPath)
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
oFile.WriteLine Application.ActiveWorkbook.FullName
wb.Save
wb.Close
Next
oFile.Close
Set fso = Nothing
Set oFile = Nothing
xl.Quit
Set xl = Nothing
Loop
Exit Sub
Else
Dim FileNum As Integer
Dim DataLine As String
FileNum = FreeFile()
Open strPath For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
Workbooks.Open DataLine
Wend
Exit Sub
End If
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub

You could use a Very-Hidden worksheet, where you'll keep all of the Files currently open.
Note: If you want there is an option to Save and Read for the Registry.
Sub CloseAllExcel Code:
Option Explicit
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if there isn't "Admin" sheet exists in the workbook
Set Hidws = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Worksheets(Worksheets.Count))
Hidws.Name = "Admin"
Hidws.Visible = xlSheetVeryHidden ' make the "Admin" sheet very-hidden
End If
i = 1
Do While xlApp Is Nothing
Set xlApp = GetObject(, "Excel.Application")
For Each wb In xlApp.Workbooks
Hidws.Range("A" & i).Value = wb.FullName ' save each workbook full name and path in column "A" in "Admin" very-hidden sheet
i = i + 1
wb.Close True
Next
xlApp.Quit
Set xlApp = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
Sub RestoreExcelLastSession Code: reads the files (names and Path) from Column "A" in "Admin" very-hidden sheet.
Sub RestoreExcelLastSession()
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if "Admin" sheet exists
MsgBox "No Files have been restored"
Exit Sub
End If
i = 1
Do While Hidws.Range("A" & i).Value <> "" ' loop through cells in Column "A"
Set xlApp = CreateObject("Excel.Application") ' open a new Excel instance per file
xlApp.Workbooks.Open (Hidws.Range("A" & i).Value)
i = i + 1
Set xlApp = Nothing
Loop
End Sub

Related

Window not visible despite running in background

I have a macro that I'm trying to run through Access that will open up an excel sheet, do some actions on it, and then leave the sheet open.
I have most of it working, with the exception of not being able to get my excel document to open visibly. If I check the task manager, an excel process is running in the background so something does happen, just nothing that I can physically see.
I've attempted to sample some code found through stackoverflow and other resources, which I'm sure you'll see some of that in my current code. But I tried for about an hour with no avail.
Private Sub Command1_Click()
Dim fd As FileDialog
Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
On Error GoTo ErrorHandler
'allowing selection of the time
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
If fd.Show = True Then
If fd.SelectedItems(1) <> vbNullString Then
MySheetPath = fd.SelectedItems(1)
End If
Else
End
End If
Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)
ShowaWindow (MySheetPath)
Set XlSheet = XlBook.Worksheets(1)
XlSheet.Rows(2).EntireRow.Insert
XlSheet.Range("D2") = "ABC"
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
Exit Sub
ErrorHandler:
Set fd = Nothing
MsgBox "Error " & Err & ": " & Error(Err)
End Sub
Sub ShowaWindow(sFileName As String)
Dim oWb As Workbook
Set oWb = GetObject(sFileName)
For Each oWb In Workbooks
If LCase(oWb.Name) <> LCase(sFileName) Then
oWb.Windows(1).Visible = True
Exit For
End If
Next
End Sub
Ideally I would like to be able to see the worksheet appear.
Set Xl = CreateObject("Excel.Application")
Xl.Visible=True
You don't need to put it immediately after creating the object, just before you set the object to Nothing.
Set XlBook = GetObject(MySheetPath)
This is wrong. Don't use GetObject to open the workbook, use the Excel.Application instance you just created:
Set XlBook = Xl.Workbooks.Open(MySheetPath)
Later you iterate all opened workbooks:
For Each oWb In Workbooks
But that's not the Workbooks collection from the Xl application instance, it's the Workbooks collection from the instance that's currently running your code - you need to qualify it with the Xl object:
Private Sub ShowaWindow(ByVal app As Excel.Application, ByVal sFileName As String)
'...
For Each oWb In app.Workbooks
Also, make the app instance visible after you created it, and don't forget to invoke XlBook.Close and Xl.Quit to properly tear down that EXCEL.EXE process when you're done.

Error: "Method 'rows' of object '_Global' failed

For some reason even though I am referring to the oSheet variable it is returning the error as if I am referring to a global variable?
PS I am trying to populate a combobox in word with a contractor names from an excel sheet I have created. I searched in google and here, none of the solutions have worked for me unfortunately. I believe the error lies within the For Each statement.
Sub Macro3()
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim oRng As Excel.Range
Dim ExcelWasNotRunning As Boolean
Dim WorkbookToWorkOn As String
'specify the workbook to work on
WorkbookToWorkOn = "C:\Users\Nathan\Desktop\KTC\VBA Experiment\Excel Files\testExcel.xlsx"
'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err Then
ExcelWasNotRunning = True
Set oXL = New Excel.Application
End If
On Error GoTo Err_Handler
'If you want Excel to be visible, you could add the line: oXL.Visible = True here; but your code will run faster if you don't make it visible
'Open the workbook
Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
'Process each of the spreadsheets in the workbook
For Each oSheet In oXL.ActiveWorkbook.Worksheets
'put guts of your code here
'get next sheet
If oSheet.Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
lastRow = 2
Else
lastRow = oSheet.Cells(Rows.Count, 1).End(xlUp).Row
End If
' For i = 2 To lastRow
' workZonerForm.contracterCMB.AddItem oSheet.Cells(i, 1)
' Next i
MsgBox lastRow
Next oSheet
If ExcelWasNotRunning Then
oXL.Quit
End If
'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing
'quit
Exit Sub
Err_Handler:
MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description, vbCritical, _
"Error: " & Err.Number
If ExcelWasNotRunning Then
oXL.Quit
End If
End Sub

VBA Excel program works only with breakpoint

This is my code for copying a sheet to new sheet.
When I ran the program with breakpoint on Workbooks.Open(path) it was working correctly but when I ran without the breakpoint it simply opened the workbook without creating any sheet.
I have tried my best to rectify the error but I couldn't get the desired result.
Sub CopyCat()
Dim ws As Worksheet
Dim no As Integer
Set ws1 = ActiveSheet
Dim path As String
temp_name = InputBox("Enter the Sheet No to be Created", "Enter the Value")
For Loop1 = 1 To ws1.UsedRange.Rows.Count
path = Application.ActiveWorkbook.path & "\" & Application.WorksheetFunction.Trim(Trim(ws1.Cells(Loop1, 1).Value)) & " " & ws1.Cells(Loop1, 2).Value & ".xlsx"
Set wb1 = Workbooks.Open(path)
'ListBox1.AddItem wb.Name
temp_name = "Sheet" & temp_name
'error1 = CheckSheet(wb1, temp_name)
'If (error1 <> True) Then
ws1.Cells(4, 1).Value = "Created" & CStr(Loop1)
Set ws = wb1.Worksheets(Sheets.Count)
ws.Copy After:=wb1.Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = temp_name
'Call PageSetting
wb1.Close SaveChanges:=True
ws1.Cells(4, 1).Value = "Created Done" & CStr(Loop1)
'Else
'wb1.Close SaveChanges:=True
'End If
Next Loop1
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
This question is a bit vague, so i assumed a few things based on the code you provided.
You want to copy a worksheet from a workbook that runs the macro to another excel file.
All file names are listed in the source worksheet, column A - let's call it "Interface" worksheet.
You will need to add reference to Microsoft Scripting Runtime in your project for the FileSystemObject to work.
Code below isnt wery well written or optimised, yet it works.
Sub CopySht(NamesRange As Range, NameOfSheetToCopy As String)
Dim fso As FileSystemObject, oFile As File, fPath As String, fNamesArr() As Variant, fFolder As Folder
Set fso = New FileSystemObject
Dim InputWb As Workbook, InterfaceWs As Worksheet
Set InputWb = ThisWorkbook
Set InterfaceWs = InputWb.Worksheets("Interface")
Dim SheetToCopy As Worksheet
Set SheetToCopy = InputWb.Worksheets(NameOfSheetToCopy)
Set NamesRange = InterfaceWs.Range(NamesRange.Address)
fNamesArr() = NamesRange.Value
fPath = InputWb.path
Set fFolder = fso.GetFolder(fPath)
Dim i As Integer
For Each oFile In fFolder.Files
For i = LBound(fNamesArr) To UBound(fNamesArr)
If oFile.Name = fNamesArr(i, 1) & ".xls" Or oFile.Name = fNamesArr(i, 1) & ".xlsx" Then
On Error Resume Next
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
Workbooks.Open (oFile.path)
If Not (CheckSheet(Workbooks(oFile.Name), SheetToCopy.Name)) Then
SheetToCopy.Copy After:=Workbooks(oFile.Name).Sheets(1)
Workbooks(oFile.Name).Close SaveChanges:=True
End If
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
End If
Next i
Next oFile
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
It doesnt matter if you pass NamesRange as qualified or unqualified range object, as shown below
Sub Wrapper()
CopySht Range("A1:A6"), "CopyMe"
'CopySht ThisWorkbook.Worksheets("Interface").Range("A1:A6"), "CopyMe"
End Sub

Choose email subject from dropdown list of excel column

I have code for emails and I want to connect to a column in an excel. When the macro is triggered, a dropdown should appear so I can choose to how to send the email depending on a list in an excel. The list is generated from other excels, it could have 2 full names or 40 full names. The list is in Sheet4 and the names are in column L, the email address is in column Q and the text in column P. If I choose from the dropdown, the name in L2, it should take the email address from Q2, the name from L2 and the text from P2. Here is what I have until now:
Sub email_to_one_person_from_the_list()
Dim OutApp As Object
Dim OutMail As Object
Dim xlApp As Object
Dim sourceWB As Object
Dim sourceWS As Object
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\persons.xlsm"
Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWH = sourceWB.Worksheets("Sheet4")
sourceWB.Activate
sourceWH.Application.Run "Module2.FetchData3"
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = sourceWH.Range("Q2").Value
.CC = ""
.BCC = ""
.Subject = "Dear " & sourceWH.Range("L2").Value
.Display
OutMail.HTMLBody = sourceWH.Range("P2").Value
sourceWB.Close SaveChanges:=False
xlApp.Quit
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
and the combobox:
Private Sub CancelButton_Click()
Unload Me
End
End Sub
Private Sub OKButton_Click()
thelist1 = ComboBox1.ListIndex
Unload Me
End Sub
Private Sub UserForm_Initialize()
With ComboBox1
' the excel list here
End With
End Sub
edited after OP's usage of my original code and further clarifications
here follows a complete refactoring code as per the following "rules"
Option Explicitstatement
this forces you to declare all variables
but this little extra work but earns you back with much more control over what your writing and less debugging and/or maintenance efforts
main "mega" code splitting into many single Sub/Funcs
this helps in
have more readable and maintainable code
keeping Userforms and Applications loading and unloading calls away from any UserForm code, which must only take care of its real work: gather information
place this in your Outlook Module:
Option Explicit
Sub email_DP2()
Dim mailData As Variant
mailData = GetMailDataFromExcel("C:\persons.xlsm", _
"Module2.FetchData3", _
"Sheet4", _
"L")
If mailData = Empty Then Exit Sub
With CreateItem(0)
.SentOnBehalfOfName = ""
.Importance = olImportanceHigh
.To = mailData(1)
.Subject = mailData(0)
.GetInspector.WordEditor.Range.collapse 1
.Display
.HTMLBody = mailData(2)
'.Paste 'what are you pasting from?
End With
End Sub
'-------------------------------------------------------
' Excel handling Subs and Funcs
'-------------------------------------------
Function GetMailDataFromExcel(strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Variant
Dim xlApp As Excel.Application
Dim closeExcel As Boolean
Dim namesRng As Excel.Range
Set xlApp = GetExcel(closeExcel)
If Not xlApp Is Nothing Then
Set namesRng = GetExcelRange(xlApp, strFile, fetchingModule, strSheet, colStrng) 'this will get the names range from given column of given worksheet of given workbook
With UserForm14
If namesRng.Count = 1 Then
.ComboBox1.AddItem namesRng.Value
Else
.ComboBox1.List = xlApp.Transpose(namesRng)
End If
.Show
With .ComboBox1
If .ListIndex > -1 Then GetMailDataFromExcel = Array(.Value, _
namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value, _
namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value)
End With
End With
Unload UserForm14
Set namesRng = Nothing
ReleaseExcel xlApp, closeExcel
End If
End Function
Function GetExcelRange(xlApp As Excel.Application, strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Excel.Range
With xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
xlApp.Run fetchingModule
With .Worksheets(strSheet)
Set GetExcelRange = .Columns(colStrng).Resize(.Cells(.Rows.Count, colStrng).End(xlUp).Row)
End With
End With
End Function
Function GetExcel(closeExcel As Boolean) As Excel.Application
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application")
If GetExcel Is Nothing Then
Set GetExcel = CreateObject("Excel.Application")
closeExcel = True
End If
If GetExcel Is Nothing Then
MsgBox "Couldn't instantiate Excel!", vbCritical
End If
End Function
Sub ReleaseExcel(xlApp As Excel.Application, closeExcel As Boolean)
If closeExcel Then xlApp.Quit
Set xlApp = Nothing
End Sub
'-------------------------------------------------------
place this in your UserForm14 code pane
Option Explicit
Private Sub btnOK_Click()
Me.Hide
End Sub
Private Sub CancelButton_Click()
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Me.Hide
End If
End Sub
in this latter I
added Option Explicit statement
although not strictly necessary (there is no variables usage but "built in" ones), it builds on a good habit
added a UserForm_QueryCloseevent handler
that handles the possible user's clicking the UserForm "Close" button
erased the End statement
I always learned it's a bad habit to use it and better stick to Exit Sub/Exit Function ones (possibly with proper mix of If.. Then.. Else blocks) to achieve the same effect without any harm
To connect your Outlook to Excel, you first have to add a reference to "Microsoft Excel XX Object Library" where XX is some version number (Extras->References)
Then create a userform, mine looks like this:
Note that my combobox has 2 columns (first one has a width of 0 so it's invisible)
Then, when you are loading the Form, add code to open an Excel instance and load the combobox with values to select from:
Private Sub UserForm_Initialize()
'Define Excel-Variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
'Create Excel Instance
Set xlApp = New Excel.Application
'Make it invisible
xlApp.Visible = False
'Open Workbook with Values
Set xlWB = xlApp.Workbooks.Open("PATH TO YOUR EXCEL FILE")
'Select the Sheet with Values
Set xlSheet = xlWB.Worksheets("sheet1")
Dim i As Integer
'Loop through the Values
For i = 1 To 30 Step 1
'This Combobox has 2 Columns where 1 is the bound one
'Add RowIndex to the first column(will be used to find the values later)
Me.cboTest.AddItem i
'Add the Name to the second Column
Me.cboTest.List(Me.cboTest.ListCount - 1, 1) = xlSheet.Cells(i, 1).Value
Next i
'Clean up and close Excel
Set xlSheet = Nothing
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
Then you need to add some code to the button:
Private Sub cmdSend_Click()
'variables for the values we are getting now
Dim name As String, email As String, text As String
'more excel variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open("PATH TO EXCEL FILE")
Set xlSheet = xlWB.Worksheets("sheet1")
'access the rowindex from the first column of the combobox
'use it for the Cells() as row
'column may be edited as needed
name = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 1).Value
email = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 2).Value
text = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 3).Value
'excel cleanup
Set xlSheet = Nothing
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
'print output to console
'instead of this, write your email
Debug.Print "mailto:" & email & " name:" & name & " text: " & text
End Sub
Then, if we open the form, we can select from the values:
If we then click the button, it will open excel and get the relevant values of the item we have selected.
Output for Name5 looks like this:
By the way, my excel example list looks like this:
#user3598756
I made the config with your code:
userform14 code:"
Private Sub btnOK_Click()
Me.Hide
End Sub
Private Sub CancelButton_Click()
Me.Hide
End
End Sub
Private Sub UserForm_Click()
End Sub
and the function code:
Sub email_DP2()
Dim name As String, email As String, text As String
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim oRng As Object
Dim StrBdB As String
Dim xlApp As Object
Dim sourceWB As Object
Dim sourceWS As Object
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\persons.xlsm"
Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWH = sourceWB.Worksheets("Sheet4")
sourceWH.Application.Run "Module2.FetchData3"
Dim pickedName As String, emailAddress As String, emailText As String
Dim namesRng As Range
With sourceWH '<== change "myWorkbookName" and "Sheet4" to your needs
Set namesRng = .Range("L1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
End With
With UserForm14 ' change it to whatever name your actual UserForm has
.ComboBox1.List = xlApp.Transpose(namesRng)
.Show
With ComboBox1
pickedName = .Value
emailAddress = namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value
emailText = namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value
End With
End With
Unload UserForm14
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
OutMail.SentOnBehalfOfName = ""
.Importance = olImportanceHigh
.To = emailAddress
.Subject = pickedName
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
.Display
OutMail.HTMLBody = emailText
oRng.Paste
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
It gives object required on line pickedName = .Value - if i eliminate the line it will give the same at line emailAddress = namesRng.Offset ... I thing is a problem with With ComboBox1 - if i eliminate with , it will generate an email but without the to, subject and text added to it.

VBA export certain data from Outlook to Excel running but producing nothing?

Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\Rob\Documents\Excel\Excel.xlsx" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step 1
If InStr(1, vText(i), "Destination -") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("a" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
This code is from online where I tried making it work for myself...
I need to extract Specific Data from emails (over 5000) and produce them on an Excel document. I've never touched VBA before only C#, Javascript & C++.
The code runs, the excel sheet updates to the current Date/time but nothing is produced?
Any help please?
I also get an error "Subscript out of range" for this line:
xlSheet.Range("A" & rCount) = Trim(vItem(1))
I think you need to change the second split delimiter to match the first one. This will take care of the Subscript error
Use this:
vItem = Split(vText(i), "Destination -")