This question already has answers here:
How to sort emails by date and open the latest email found?
(2 answers)
Closed 11 months ago.
I would like to extract only the latest or today attachment.
I can only get one attachment and it is always the first (oldest) email.
Sub Download_Attachments()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("nflow")
Dim msg As Outlook.MailItem
Dim fo As Outlook.Folder
Dim at As Outlook.Attachment
Set fo = Outlook.GetNamespace("MAPI").Folders("XXXXX").Folders("Inbox").Folders("Ad Hoc").Folders("XXXX")
'Set fo = Outlook.GetNamespace("MAPI").Folders("XXXX#XXXX.com").Folders("Inbox").Folders("test")
'Filter folder
' Set oOlInbFiltered = fo.Items.Restrict("[UnRead] = True AND [Subject] = 'TEST SUBJECT' AND [ReceivedTime]>='" & Format(Date, "DDDDD HH:NN") & "'")
Dim lr As Integer
Dim count As Integer
count = 0
For Each msg In fo.Items
lr = Application.WorksheetFunction.CountA(sh.Range("A:A"))
sh.Range("A" & lr + 1).Value = msg.Subject
sh.Range("B" & lr + 1).Value = msg.Attachments.count
If count = 0 Then
For Each at In msg.Attachments
If VBA.InStr(at.Filename, ".xlsx") > 0 Then
at.SaveAsFile sh.Range("G1").Value & "\" & at.Filename
End If
Next
'count = count + 1
End If
Use the (commented out) line of your code that calls Restrict(). You can also call oOlInbFiltered.Sort to sort on the received time.
Related
I found the below script online and tried to modify. I would like to check the Color Category instead of flagged emails.
So as an example, it would not check if an email is flagged and then export the details to excel, but it would export all and add a Column 6 about the Category (name) the email is marked.
Here is the code for processing the emails in Outlook
Sub ProcessMailFolders(ByVal objCurrentFolder As Outlook.Folder)
Dim i As Long
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem
Dim nLastRow As Integer
Dim objSubfolder As Outlook.Folder
For i = 1 To objCurrentFolder.Items.Count
If objCurrentFolder.Items(i).Class = olMail Then
'Export the information of each flagged email to Excel
Set objMail = objCurrentFolder.Items(i)
If objMail.IsMarkedAsTask = True And objMail.FlagStatus <> olFlagComplete Then
Set objFlaggedMail = objMail
With objExcelWorksheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFlaggedMail.Subject
.Range("B" & nLastRow) = objFlaggedMail.TaskStartDate
.Range("C" & nLastRow) = objFlaggedMail.TaskDueDate
.Range("D" & nLastRow) = objFlaggedMail.SenderName
.Range("E" & nLastRow) = objFlaggedMail.To
End With
End If
End If
Next i
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessMailFolders(objSubfolder)
Next
End If
End Sub
The code referring to Excel I was able to modify, but not with checking the categorisation instead of flagged emails.
You need to alter the 'if' statement. Mail Items have a property called categories which returns a string.
Change:
If objMail.IsMarkedAsTask = True And objMail.FlagStatus <> olFlagComplete Then
To:
If objMail.Categories = ***Insert Category Name In Quotes*** Then
hi i want open the latest files in the folders when i run the below code getting run time error 1004, the issue is LatestFile hold the previous folder of latest excel file. note - code is opening the first two folders of latest file and then getting the error. please let me know how to fix the issue.
Sub Esskay()
Dim foldname, FolderName, subfold1, subfold2, strFilename As String
Dim FileName, myfile2, myFoldert As Workbooks
Dim sht, ws As Worksheet
Dim bottomMostRow As Long, rightMostColumn, Lastrow As Long
Dim FileSys, objFile, myFolder, c As Object
Dim misfile As Workbook
Dim rngLocation, rngLocation2 As Range
Dim rngNewCol As Range
Dim lrow, lrw, lcol As Long
Dim MyFiled As String
Dim LatestFile, Mypath As String
Dim LatestDate As Date
Dim LMD As Date
foldname = "C:\Users\ashokkumar.d\Desktop\Test\"
Lastrow = Workbooks("as").Sheets(1).Range("A" & Rows.count).End(xlUp).Row
For k = 2 To Lastrow
subfold1 = Workbooks("as").Sheets(1).Cells(k, 1).Value
subfold2 = Workbooks("as").Sheets(1).Cells(k, 2).Value
FolderName = (foldname + subfold1 + "\" + subfold2 + "\" + "MIS" + "\")
'Make sure that the path ends in a backslash
If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
'Get the first Excel file from the folder
MyFiled = Dir(FolderName & "*.xls")
'If no files were found, exit the sub
If Len(MyFiled) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
'Loop through each Excel file in the folder
Do While Len(MyFiled) > 0
'Assign the date/time of the current file to a variable
LMD = FileDateTime(FolderName & MyFiled)
'If the date/time of the current file is greater than the latest
'recorded date, assign its filename and date/time to variables
If LMD > LatestDate Then
LatestFile = MyFiled
LatestDate = LMD
End If
'Get the next Excel file from the folder
MyFiled = Dir
Loop
'Open the latest file
Set myfile2 = Workbooks.Open(FolderName & LatestFile)
next
end sub
I've been following this site for years now and learned a lot from it, but this time I'm really stuck. So, time for me to finally register huh! :-)
At work, we have 19740 Word documents (no lie!) that need to be processed. It are all invoices. To make it more understandable, I uploaded a file, which can be found here: http://1drv.ms/1U7SsHH
All files have the same layout and structure. I marked everything that needs to get extracted in a color. I also need the filename of each Word document in the first Excel column.
The Excel file should look like something like this with its columns:
Filename
Factuurnummer (yellow)
Leerling (red)
Vervaldatum (green)
Datum (turquoise)
Algemeen Totaal (blue)
Mededeling (lilac)
Note: the cell marked blue isn't always the same. Here's an example of such file: http://1drv.ms/1U7SFLa
I found a script online, but it extracts everything in only the table and puts it all in one colomn.. It's been almost 7 years since I last wrote a VBA script, so I'm really rusty... /ashamed
I really hope that you guys can help me out here! Thanks in advance!
EDIT: forgot to place my current code here, sorry!
Sub omzetting()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
Application.ScreenUpdating = False
Set oWord = CreateObject("Word.Application")
sPath = "C:\Users\Andy\Desktop\SGR14\edusoft\facturen\sgr14_all\kopie" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
r = 1 'start rij
c = 1 'start kolom
Cnt = 0
Do While Len(sFile) > 0
Cnt = Cnt + 1
Set oDoc = oWord.Documents.Open(sPath & sFile)
For Each oCell In oDoc.Tables(1).Range.Cells
Cells(5, 6).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
oDoc.Close savechanges:=False
r = r + 1
c = 1
sFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then
MsgBox "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
End Sub
I would
Read the invoice
Create a variant array that consists of only the relevant items, some of which will need to be processed so as to deal with ensuring the Dates are properly translated (VBA tends to be US-centric), and that we remove extraneous, non-printing characters
Collect each variant array as what will be a row into a collection
after processing all the files, write the row collection into a results array and write it to the worksheet.
EDIT: If you examine closely, you will find that totaal is in a particular cell in a subtable of the main table. So the processing can be shortened considerably.
I did not see anything "lilac", so I did not collect Mededeling, but you should be able to figure that out from the code I provided.
The code works on the two invoices you provided, but may need some work depending on the variability of your data.
I tried to keep most of your code.
Option Explicit
Sub omzetting()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim sPath As String
Dim sFile As String
Dim oTbl As Word.Table
Dim colRow As Collection
Dim V(1 To 7) As Variant
Dim I As Long, J As Long
Dim vRes() As Variant
Dim rRes As Range
Set rRes = Cells(1, 1)
Set oWord = New Word.Application
Set colRow = New Collection
'Change sPath to reflect the folder in YOUR system
sPath = "d:\Users\Ron\Desktop\New Folder\" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
Do While Len(sFile) > 0
Set oDoc = oWord.Documents.Open(sPath & sFile, ReadOnly:=True)
V(1) = sPath & sFile 'Filename
Set oTbl = oDoc.Tables(1)
With oTbl
With .Range
V(2) = .Cells(11).Range.Text 'Factuumummer (yellow)
V(3) = .Cells(6).Range.Text ' Leerling (red)
V(4) = .Cells(13).Range.Text 'Vervaldatum (green)
V(5) = .Cells(15).Range.Text 'Datum (turquoise)
End With
With oTbl.Tables(2).Range
V(6) = .Cells(3).Range.Text 'Algemeen Totaal (blue)
End With
'V(7) = wherever Mededeling is
End With
'Remove unneeded characters
For J = 1 To 7
V(J) = Replace(V(J), vbCr, "")
V(J) = Replace(V(J), vbLf, "")
V(J) = Replace(V(J), Chr(7), "")
Next J
'Process dates and values
V(4) = DateSerial(Right(V(4), 4), Mid(V(4), 4, 2), Left(V(4), 2))
V(5) = DateSerial(Right(V(5), 4), Mid(V(5), 4, 2), Left(V(5), 2))
'Add to collection
colRow.Add V
oDoc.Close savechanges:=False
sFile = Dir
Loop
If colRow.Count = 0 Then
MsgBox "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
'Set up and populate results array
'Could dim vRes(0 to ....) and use Row 0 for column labels
ReDim vRes(1 To colRow.Count, 1 To 6)
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vRes, 2)
vRes(I, J) = colRow(I)(J)
Next J
Next I
'write results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
All,
How can I modify the code below to not just grab the first table of each word document in a specific folder but to extract all of the tables from each document? I've tried manipulating the code myself but I can't seem to get it right. Any help would be greatly appreciated.
Option Explicit
Sub test()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
Application.ScreenUpdating = False
Set oWord = CreateObject("Word.Application")
sPath = "C:\Users\Domenic\Desktop\" 'change the path accordingly
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
r = 2 'starting row
c = 1 'starting column
Cnt = 0
Do While Len(sFile) > 0
Cnt = Cnt + 1
Set oDoc = oWord.Documents.Open(sPath & sFile)
For Each oCell In oDoc.Tables(1).Range.Cells
Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
oDoc.Close savechanges:=False
r = r + 1
c = 1
sFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then
MsgBox "No Word documents were found...", vbExclamation
End If
End Sub
Dim tbl
'........
Set oDoc = oWord.Documents.Open(sPath & sFile)
For each tbl in oDoc.Tables
For Each oCell In tbl.Range.Cells
Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
r = r + 2 'couple of blank rows between tables
c = 1
Next tbl
oDoc.Close savechanges:=False
'.........
I want to update Powerpoint Graph 2010 from Excel 2010.
Code looks for the Objects and finds the range with name similar in powerpoint, it applies changes to the graph. Graph format should be same only data must be updated.
Code is as follow, it is not able to find charts, either able to update it.
Option Explicit
Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"
Private m_sLog As String
Private Sub CommandButton1_Click()
On Error GoTo Catch
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim mgrChart As Chart
Dim mgrDatasheet As Graph.DataSheet
Dim rngData As Excel.Range
Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long
Dim i As Integer
Dim fLog As frmLog
Dim Box1Status As VbMsgBoxResult
m_sLog = ""
'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub
i = 1
UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized
'Looks for (tagged) charts to update
UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoEmbeddedOLEObject Then
If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then
nFound = nFound + 1
Set mgrChart = pptShape.OLEFormat.Object
Set mgrChart = pptShape.Chart
Set mgrDatasheet = mgrChart.Application.DataSheet
With mgrDatasheet
sTag = .Cells(1, 1)
If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
Set rngData = RangeForChart(sTag)
If rngData Is Nothing Then
' This chart has no data in this Excel workbook
If Left(sTag, 6) <> "Export" Then
UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
Else
UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
End If
Else
' Update the PowerPoint chart with the Excel data
UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
.Cells.ClearContents
For iRow = 0 To rngData.Rows.Count - 1
For iCol = 0 To rngData.Columns.Count - 1
.Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
Next iCol
Next iRow
.Application.Update
UpdateStatus "Chart with tag '" & sTag & "' updated."
nUpdated = nUpdated + 1
End If
End With
Set mgrDatasheet = Nothing
mgrChart.Application.Quit
Set mgrChart = Nothing
End If
'End If
Next pptShape
i = i + 1
Next pptSlide
UpdateStatus "Finished searching presentation. Closing PowerPoint."
pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."
Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub
Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub
Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range
Set NameList = Range("Name_List")
If Left(sTag, 6) <> "Export" Then Exit Property
'For Each nRow In NameList.Rows
Do While sChartTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "Export_", which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
'Next nRow
Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange
End Property
Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long
If Left(sTag, 10) <> "ExportText" Then Exit Property
Do While sTextTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange
End Property
Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub
Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub
I don't think you need a bunch of code for this.
Build the charts in Excel, copy them, go to PowerPoint, use Paste Special - Link. Change the data in Excel, and the Excel charts update. Then open the PowerPoint presentation, and if necessary, update links.
In the data sheet for your powerpoint graph, you can "link" the cells to your excel data file by typing in one of the cells (path and file name are made up here)
=c:\PPTXfiles\excelfiles[excelfiles.xlsx]sheetname'!a1
This will create a link that doesn't show up in the links section of powerpoint, but can be updated just by opening both files and double clicking on the chart to activate it.
Sometime the paste by link feature isn't feasible to use since the end user of the file wants to "break it up" and send out parts. That is not possible without the source excel file, since the end users want to be able to edit the chart or the data.
If you can do this and then copy and paste the data sheet by values in VBA, before sending to the enduser that would be fantastic.
Bam!
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
'Open a dialog box to promt for the new source file.
ExcelFile = exl.Application.GetOpenFilename(, , "Select Excel File")
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
'Turn of error checking s that it doesn 't crash if the current shape doesn't already have a link
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.Update
End If
On Error GoTo 0
Next k
End With
Next i
End Sub