I've looked on many sites, including all the questions that came up when I entered my title, and I can't seem to get my program to work. It activates the spreadsheet, but no data prints.
Option Explicit
Dim objExcel, objWorkbook
Dim strTIN, strName, strFName, strLName, strState, strEmpID, strRecDate, strComment
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\lpeder6\Desktop\Important Info\Data tracking.xlsx")
CopyData
Set objExcel = Nothing
Set objWorkbook = Nothing
'---------------CopyData - Copies required data-----------------
Sub CopyData()
strTIN = "2-123456789-00005"
strName = "Smith John "
strState = "MN"
strEmpID = "S987654321"
strRecDate = "04/02/2015"
strComment = "This is all that is in my comment."
strLName = Trim(Left(strName, 10))
strFName = Trim(Right(strName, 15))
strName = strLName & " " & strFName
objExcel.Visible = True
objWorkbook.Sheets(1).Activate
objWorkbook.Sheets(1).Cells(1, 1).Value = strTIN
objWorkbook.Sheets(1).Cells(1, 2).Value = strName
objWorkbook.Sheets(1).Cells(1, 3).Value = strState
objWorkbook.Sheets(1).Cells(1, 4).Value = strEmpID
objWorkbook.Sheets(1).Cells(1, 5).Value = strRecDate
objWorkbook.Sheets(1).Cells(1, 6).Value = strComment
objExcel.ActiveWorkbook.Close
End Sub
Any ideas will be greatly appreciated.
By 'no data prints', I'm assuming that you mean the data you input is not stored. This is because you are not saving the workbook as you close it. Change one line in the sub to:
objExcel.ActiveWorkbook.Close true
See Workbook.Close Method (Excel) for full syntax reference.
Related
I need to create a new Excel file with data from a main (with VBA) Excel file.
I can only Save as and it is saving my main Excel file.
I need a copy of this file with certain cells and columns.
How the copy of the Excel file should look
I have this.
Private Sub CommandButton2_Click()
Dim newExcel As Excel.Application
Dim newWorkbook As Excel.Workbook
Dim newWorkSheet As Excel.Worksheet
Set newExcel = CreateObject("Excel.Application")
Set newWorkbook = newExcel.Workbooks.Add
Set newWorkSheet = newWorkbook.Worksheets(1)
newWorkSheet.Range("A1") = "Klients"
newWorkSheet.Range("B1") = "Bilance 06.17"
newWorkSheet.Range("C1") = "Bilance 07.17"
newWorkSheet.Range("D1") = "Bilance 08.17"
newWorkSheet.Range("E1") = "Bilance 09.17"
newWorkSheet.Range("F1") = "Bilance 10.17"
newWorkSheet.Range("G1") = "Kopa"
newWorkSheet.Range("A2") = TextBox1.Text
newWorkSheet.Range("B2") = TextBox2.Text
newWorkSheet.Range("C2") = TextBox3.Text
newWorkSheet.Range("D2") = TextBox4.Text
newWorkSheet.Range("E2") = TextBox5.Text
newWorkSheet.Range("F2") = TextBox6.Text
newWorkSheet.Range("G2") = TextBox7.Text
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & newExcel
.Execute
End Sub
Try maybe this:
With newExcel
.Visible = True
With .FileDialog(msoFileDialogSaveAs)
.InitialFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & newExcel.Workbooks(1).name
.Show
'.Execute
End With
' If you nedd to close
.Quit
Thisworkbook.Activate
End With
Create a new instance, copy the values to it and then save that instance(new). You haven't shown the code where you tried to save it. newWorkbook.saveas where you put the filename parameter from filedialogbox should work.
Or just do NewWorkbook.Save since it is a new workbook, the filename picker may apper by default.
I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows and not needed blue rows. How can I delete this complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
With wsTarget
Fcol.Copy .Range("A2")
Acol.Copy .Range("B2")
Ecol.Copy .Range("C2")
End With
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim ix
with wsTarget
for ix = rowcount + 1 to 2 step -1
if Len(.cells(ix,1))=0 and len(.cells(ix,2))=0 and len(.cells(ix,3))=0 then
.rows(ix).delete
'//Check for blue rows assuming all cells in the row have the same color
elseif .cells(ix, 1).Interior.Color = iBlueColor then
.rows(ix).delete
end if
next
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Function Max(v1, v2, v3)
select case true
case v1 => v2 and v1 => v3
Max = v1
case v2 => v3
Max = v2
case else
Max = v3
end select
end function
This is an alternative approach to my original in an attempt to improve performance. In this case, instead of using Excel to create the csv file, the VBScript code writes the csv file directly using a text file created by FileSystemObject. I have tested this with a larger set of source data and it seems to be quite a bit quicker than the original - about 40 seconds for 1500 rows. There is still an overhead of opening the Excel application (about 5-10 seconds) but there's not much you can do about that. If performance is important to you there may be other improvements that you could do.
If you have numeric values in the spreadsheet, you may need to do some formatting to convert to string values suitable for csv output, because Excel tends to use exponential notation for numbers converted to text, which is not always what you want. I have also used quotation marks and comma separators but you could use different formatting conventions for your CSV output. You may want to change the use of WriteLine because this appends a CrLf after the last line, which might be interpreted downstream as a blank row.
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
msgbox "starting"
call xlsToCsv()
msgbox "finished"
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
Dim oOutputFile
myFile = "source_file.xlsx"
SaveName = "test2.csv"
With CreateObject("Scripting.FilesystemObject")
'// Check that the input file exists
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
'// Create a text file to be the output csv file
'// Overwrite v v False=ASCII format use True for Unicode format
set oOutputFile = .CreateTextFile( WorkingDir & SaveName, True, False)
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
oOutputFile.WriteLine """ID"",""NAME"",""DESC"""
'// Get the three column ranges, starting at cells in row 7
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
'// Get the number of rows in each column
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
'// Rowcount is the max row of the three
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim AVal, FVal, EVal
dim ix
for ix = 1 to rowcount
'// Note - row 1 of each column is actually row 7 in the workbook
AVal = REPLACE(ACol.Cells(ix, 1), """", """""")
EVal = REPLACE(ECol.Cells(ix, 1), """", """""")
FVal = REPLACE(FCol.Cells(ix, 1), """", """""")
'// Check for an empty row
if Len(AVal)=0 and len(EVal)=0 and len(FVal)=0 then
'// skip this row
'// Check for a blue row
elseif ACol.cells(ix,1).Interior.Color = iBlueColor then
'// skip this row
else
'// Write the line to the csv file
oOutputFile.WriteLine """" & FVal & """,""" & AVal & """,""" & EVal & """"
end if
next
'// Close the output file
oOutputFile.Close
'// Close the workbook
objWorkbook.Close True
objExcel.Quit
'// Clean up
Set oOutputFile = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
Function Max(v1, v2, v3)
select case true
case v1 >= v2 and v1 >= v3
Max = v1
case v2 >= v3
Max = v2
case else
Max = v3
end select
end function
Good Morning
I'm trying to clean up a macro that is behaving erraticly. It used to work - on a good day. But it throws up this error: "Microsoft Excel is waiting for another application to complete an OLE action". I've tried to clean it up (which caused all sorts of other errors, now sorted) and I'm back to being able to step through it but it again stops at above error.
What I have noticed that it used to do one certificate and then throw the error but now the error occurs straight away when it's trying to open the template. This is the line:
Set objMMMD = objWord.Documents.Open(cDir & WTempName)
objMMMD.Activate
My original thought was that the code didn't close Word cleanly but now that the error is so early, that can't be it. I don't have Word open. - Since it used to open Word before my revision, the code should be correct as well.
I can't find much on the error apart from that it seems to occur in more complicate codes due to timeout and how to suppress the message. Neither seems to be of help here.
Below the entire code. Does anybody have any idea why Excel can't open Word to do the mailmerge?
Public Sub MailMergeCert()
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim FirstName As String
Dim LastName As String
Dim Training As String
Dim SeminarDate As String
Dim HoursComp As String
Dim Location As String
Dim Objectives As String
Dim Trainer As String
Dim cDir As String
Dim ThisFileName As String
'Your Sheet names need to be correct in here
Dim sh1 As Worksheet
Set sh1 = ActiveWorkbook.Sheets("Ultrasound")
Dim r As Long
r = 2
FirstName = sh1.Cells(r, 1).Value
LastName = sh1.Cells(r, 2).Value
Training = sh1.Cells(r, 3).Value
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY")
HoursComp = sh1.Cells(r, 5).Value
Location = sh1.Cells(r, 6).Value
Objectives = sh1.Cells(r, 7).Value
Trainer = sh1.Cells(r, 8).Value
'Setup filenames
Const WTempName = "Certificate_Ultrasound_2017.docx" 'Template name
'Data Source Location
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name
On Error Resume Next
'Create Word instance
bCreatedWordInstance = False
Set objWord = CreateObject("Word.Application")
If objWord Is Nothing Then
Err.Clear
Set objWord = CreateObject("Word.Application")
bCreatedWordInstance = True
End If
If objWord Is Nothing Then
MsgBox "Could not start Word"
Err.Clear
On Error GoTo 0
Exit Sub
End If
' Let Word trap the errors
On Error GoTo 0
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir & WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir & ThisFileName, _
sqlstatement:="SELECT * FROM `Ultrasound$`" ' Set this as required
lastrow = Sheets("Ultrasound").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lastrow
If IsEmpty(Cells(r, 11).Value) = False Then GoTo nextrow
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
End With
.Execute Pause:=False
End With
'Save new file PDF
Dim UltrasoundCertPath As String
UltrasoundCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Ultrasound\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 16).Value, "YYMM")
Dim NewFileNamePDF As String
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 3).Value & "_" & sh1.Cells(r, 7).Value '& ".pdf" 'Change File Name as req'd"
objWord.ActiveDocument.ExportAsFixedFormat UltrasoundCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF
nextrow:
Next r
End With
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
If bCreatedWordInstance Then
objWord.Quit
End If
Set objWord = Nothing
Cells(r, 11).Value = Date
0:
Set objWord = Nothing
End Sub
Try changing
cDir = ActiveWorkbook.Path + "\"
To
cDir = ActiveWorkbook.Path & "\"
Does that make a difference. Also try printing the cDir if its what expect.
Try message box the cDir to check the path.
MsgBox(cDir, vbOKOnly, "Testing cDir")
I have a worksheet (QT) that gets filled in by the user and when the user closes the workbook a UserForm appears before closing. The user then selects a few things and the code runs. The code inserts data into another workbook (Log). My problem is the other workbook (Log) asks the user if they would like to save. I need for this step to be skipped. I have tried Application.DisplayAlerts = False but it does not prevent it from popping up.
Private Sub OKBTN_Click()
Dim TOTALFOB As String
Dim TOTALWC As String
Dim MFG As String
Dim JOB As String
Dim XL As Excel.Application
Dim wbk As Excel.Workbook
Dim INWBK As Excel.Workbook
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim visitdate As Date
Dim visitdate_text As String
TOTALFOB = RefEdit1
TOTALWC = RefEdit2
Set XL = CreateObject("Excel.Application")
Set INWBK = ActiveWorkbook
Set wbk = XL.Workbooks.Open("C:\QUOTE REQUEST LOG 2015.xlsm")
If YESBTN.Value = True Then TOTMFG = INWBK.Sheets("QTR").Range(TOTALFOB).Value
If YESBTN.Value = True Then TOTWC = INWBK.Sheets("QTR").Range(TOTALWC).Value
If NOBTN.Value = True Then TOTMFG = "N/A"
If NOBTN.Value = True Then TOTWC = "N/A"
MFG = INWBK.Sheets("QTR").Range("B7").Value
JOB = INWBK.Sheets("QTR").Range("H13").Value
visitdate = INWBK.Sheets("QTR").Range("H9").Value
visitdate_text = Format$(visitdate, "mm\-dd\-yyyy")
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = INWBK.Sheets("QTR").Range("B7").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 1) = INWBK.Sheets("QTR").Range("H11").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 3) = INWBK.Sheets("QTR").Range("H13").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 4) = TOTMFG
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 5) = TOTWC
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 6) = "OPEN"
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 7) = INWBK.Sheets("QTR").Range("H9").Value
Application.DisplayAlerts = False
INWBK.SaveAs Filename:="C:\. QUOTE REQUESTS" & _
"\DCS QTR " & MFG & " " & " " & JOB & " " & visitdate_text & ".xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
Set XL = Nothing
Unload Me
wbk.Close
End Sub
Code from output file (Workbook Log):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.Save
End Sub
try ThisWorkbook.Saved = True
Even if the workbook is not saved, excel will act as if it was saved
A few months I had a lot of help to write this script. It reads the incoming email and, if the subject is equal to the "Report of Property", it reads the email and opens a file and inserts the values.
This is what's happening:
It opens the file and inserts the values in the correct colums.
What it isn't doing:
I want it to find the first empty line in the spreadsheet and paste the values there.
I want it to save and close the spread sheet when it's done.
Because of the number of emails I'm getting, i would like to know how to run this on a button instead of it reading all emails that come in. Example: I would create a rule in Outlook to move all emails with the specified subject to a folder called "Maintenance Reports". Then, If possible, I would run the macro from that folder and get all the values into the spreadsheet at the end on the day. Is this difficult to accomplish?
Here is the script or VBA code:
Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim id As Variant
Dim email As Outlook.MailItem
Dim msgText As Variant
Set xlApp = CreateObject("Excel.Application")
For Each id In Split(EntryIDCollection, ",")
Set email = Application.Session.GetItemFromID(id)
If email.Subject = "Report of Property" Then
Dim line As Variant
Set xlWB = xlApp.Workbooks.Open(FileName:="C:\Users\George\Desktop\gs.xlsx", AddTOMRU:=False, UpdateLinks:=False)
Set xlSheet = xlWB.Worksheets(1)
line = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Offset(1).Row
For Each line In Split(email.Body, vbCrLf)
If Left(line, 5) = "Name:" Then
xlSheet.Range("B6").Value = Trim(Mid(line, 6))
ElseIf Left(line, 12) = "Time started" Then
xlSheet.Range("A6").Value = DateValue(Trim(Mid(line, 14)))
ElseIf Left(line, 8) = "Sage nº:" Then
xlSheet.Range("D6").Value = Trim(Mid(line, 9))
ElseIf Left(line, 19) = "Complete Checklist:" Then
xlSheet.Range("F6").Value = Trim(Mid(line, 20))
ElseIf Left(line, 4) = "Job:" Then
xlSheet.Range("G6").Value = Trim(Mid(line, 6))
ElseIf Left(line, 9) = "Materials" Then
xlSheet.Range("W6").Value = Trim(Mid(line, 13))
ElseIf Left(line, 8) = "Duration" Then
xlSheet.Range("K6").Value = Trim(Mid(line, 12))
End If
Next
Else:
End If
xlApp.Visible = True
Next
End Sub
Any help is welcome. Thank you in advance!
George
I will try to answer the Outlook related part of your questions:
Because of the number of emails I'm getting, i would like to know how to run this on a button instead of it reading all emails that come in. Example: I would create a rule in Outlook to move all emails with the specified subject to a folder called "Maintenance Reports". Then, If possible, I would run the macro from that folder and get all the values into the spreadsheet at the end on the day. Is this difficult to accomplish?
Of course, creating a new instance of the Excel Application class in the NewMailEx event handler is not the right idea.
Also Outlook doesn't provide any way for customizing the UI using VBA. You need to develop an Outlook add-in instead. See Walkthrough: Creating Your First Application-Level Add-in for Outlook for more information.
You can use the Find/FindNext or Restrict methods to find all items in the folder that correspond to your criteria. See the following articles for more information and sample code:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Well, despite the negative rating, I managed to get this to work following Jean-François Corbett advice. But to be true, I didnt ask the question because I wanted a solution. I askedthe question because i wanted some instruction how to get there. Here is the answer for anyone who would like to try:
Option Explicit
Sub Export()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim id As Variant
Dim email As Outlook.MailItem
Dim msgText As Variant
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Open(FileName:="C:\Users\User\Desktop\gsmaster.xlsm", AddTOMRU:=True, UpdateLinks:=True)
Set xlSheet = xlWB.Worksheets("LLCHARGES")
Dim LR As Long
LR = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row + 1
Set email = Application.ActiveExplorer().Selection(1)
If email.Subject = "Report of Property" Then
Dim line As Variant
For Each line In Split(email.Body, vbCrLf)
If Left(line, 4) = "Date" Then
xlSheet.Range("A" & LR).Value = DateValue(Trim(Mid(line, 6)))
ElseIf Left(line, 5) = "Name:" Then
xlSheet.Range("B" & LR).Value = Trim(Mid(line, 6))
ElseIf Left(line, 8) = "Sage nº:" Then
xlSheet.Range("D" & LR).Value = Trim(Mid(line, 9))
ElseIf Left(line, 19) = "Complete Checklist:" Then
xlSheet.Range("V" & LR).Value = Trim(Mid(line, 20))
ElseIf Left(line, 4) = "Job:" Then
xlSheet.Range("G" & LR).Value = Trim(Mid(line, 5))
ElseIf Left(line, 9) = "Materials" Then
xlSheet.Range("W" & LR).Value = Trim(Mid(line, 13))
ElseIf Left(line, 8) = "Duration" Then
xlSheet.Range("X" & LR).Value = Trim(Mid(line, 12))
xlWB.Close SaveChanges:=True
xlApp.Quit
Set xlApp = Nothing
Else
End If
Next
Set xlApp = Nothing
MsgBox ("Exporting Finished!")
Else
MsgBox "Not report email!"
End If
End Sub
Sub Issue()
Dim xlApp2 As Excel.Application
Dim xlWB2 As Excel.Workbook
Dim xlSheet2 As Excel.Worksheet
Dim id As Variant
Dim email As Outlook.MailItem
Dim msgText As Variant
Set xlApp2 = CreateObject("Excel.Application")
Set xlWB2 = xlApp2.Workbooks.Open(FileName:="C:\Users\User\Desktop\Work.xlsm", AddTOMRU:=True, UpdateLinks:=True)
Set xlSheet2 = xlWB2.Worksheets("issues")
Dim LR As Long
LR = xlSheet2.Range("A" & xlSheet2.Rows.Count).End(xlUp).Row + 1
Set email = Application.ActiveExplorer().Selection(1)
Dim line As Variant
For Each line In Split(email.Body, vbCrLf)
If Left(line, 12) = "Unrepairable" Then
MsgBox "Issue found!"
xlSheet2.Range("C" & LR).Value = Trim(Mid(line, 28))
ElseIf Left(line, 8) = "Sage nº:" Then
xlSheet2.Range("A" & LR).Value = Trim(Mid(line, 9))
ElseIf Left(line, 5) = "Date:" Then
xlSheet2.Range("D" & LR).Value = DateValue(Trim(Mid(line, 6)))
Else
If Left(line, 15) = "No unrepairable" Then
MsgBox "No Issues found!"
End If
End If
Next
xlWB2.Close SaveChanges:=True
xlApp2.Quit
Set xlApp2 = Nothing
Beep
MsgBox "Document has been processed!"
End Sub
Then I just created a button on the ribbon that would run the macros in turn. Solved with patience, trial and error.
I post the answer to help other people, like me, who are getting started and need some guidance.
To those who helped: Thank you! To those who didn't: Thank you too! For the incredibly smart who think that everyone is born smart, that each individual must express himself in binary so that you may understand, i say: .....!
You'll need to check each line in the worksheet for a blank value. Then if it's blank fill that row. Like so:
Dim blankLine As Long
blankLine = 2 'or wherever you want to start
Do
If xlSheet.Cells(1,1).Value = "" Then
Exit Do
End If
blankLine = blankLine + 1
Loop
You'll then want to use blankLine in each statement where your filling in a value on the spreadsheet. For example, xlSheet.Cells(2, blankLine).Value = Trim(Mid(line, 6)).
To save and close the workbook, call the .Save and .Close methods on the workbook. Example, xlWB.Save.
There are many good examples of how to add a custom button to the ribbon on MSDN. Try https://msdn.microsoft.com/en-us/library/office/ee767705%28v=office.14%29.aspx. Search around. There's lots of tutorials out there. Essentially you'll want to wrap what you currently have inside some code that will let you loop through all the messages in a particular folder. Outlook exposes its object model for that. Check out https://msdn.microsoft.com/en-us/library/office/ee814736%28v=office.14%29.aspx.
Good luck!