Outlook Excelanhang Daten exportieren
14.11.2022 22:54:06
Steffen
ich habe eine Frage zu VBA Outlook was für mich noch komplettes Neuland ist.
Ich bekomme mehrere E-Mail auf die in Outlook hinterlegt E-Mail Adresse. In jeder E-Mail ist eine Excel Datei hinterlegt.
In dieser Datei ist in Zeile 1 die Beschriftung um was für ein Wert es sich in Zeile 2 handelt. (siehe: https://www.herber.de/bbs/user/156181.xlsx)
Ich möchte jetzt sobald eine E-Mail ankommt, dass die Werte im Anhang Zeile 2 in eine auf dem PC abgelegte Excel-Datei in die nächste freie Zeile kopiert werden.
Dabei kann es vorkommen, dass nicht alle Zellen der Zeile 2 gefüllt sind!
Der folgende Code habe ich bis jetzt verwendet, wobei aber immer ein Fehler kommt wenn nicht in jeder Zelle ein Wert ist.
Außerdem muss ich das ganze immer manuell pro E-Mail ausführen.
Public Sub ExportFromExelAttachmentToExcelFile()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim excelOnHardDisk As String
Dim i As Long
Dim lngCount As Long
Dim excelWorkbookMail As Workbook
Dim excelWorkbookHD As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim dict As Dictionary
Dim varKey As Variant
Dim unusedRow As Long
'Pfad zur Excel-Datei in die importiert werden soll
excelOnHardDisk = "c:\Users\DeinUser\Documents\temp\Import1.xlsx"
'Name des Tabellenblatt in das importiert werden soll
Sheet = "Ergebniserfassung"
'Spalten zuordnen; erster Werte Excel-Spalte des E-Mail-Anhangs aus der exportiert werden soll, zweiter Werte Excel-Spalte in die importiert werden soll
Set dict = New Dictionary
dict.Add "A", "A"
dict.Add "B", "B"
dict.Add "C", "C"
dict.Add "D", "D"
dict.Add "E", "E"
dict.Add "F", "F"
dict.Add "G", "G"
dict.Add "H", "H"
dict.Add "I", "I"
dict.Add "J", "J"
dict.Add "K", "K"
dict.Add "L", "L"
dict.Add "M", "M"
dict.Add "N", "N"
dict.Add "O", "O"
dict.Add "P", "P"
dict.Add "Q", "Q"
dict.Add "R", "R"
' Outlook Application Objekt
Set objOL = CreateObject("Outlook.Application")
' Collection der ausgewählten Objekte (E-Mails) ermitteln
Set objSelection = objOL.ActiveExplorer.Selection
'Erste ausgewählte E-Mail benutzen
Set objMsg = objSelection.Item(1)
' Die Anhänge des ausgewählten Objekts (E-Mail) ermitteln
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Dateinamen ermitteln
strFile = objAttachments.Item(i).FileName
'prüfen, ob es eine Excel-Datei ist
FileExtension = LCase(Right$(strFile, Len(strFile) - InStrRev(strFile, ".")))
If FileExtension = "xls" Or FileExtension = "xlsx" Then
tempFolderPath = Environ("Temp") + "\" + strFile
' Excel-Datei temporär als Datei speichern
objAttachments.Item(i).SaveAsFile tempFolderPath
Set excelWorkbookMail = Workbooks.Open(tempFolderPath)
Set ws2 = excelWorkbookMail.Sheets(1)
Set excelWorkbookHD = Workbooks.Open(excelOnHardDisk)
Set ws = excelWorkbookHD.Worksheets(Sheet)
'erste freie Zeile in Tabellenblatt ermitteln
unusedRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
For Each varKey In dict.Keys()
orignRange = varKey & "2"
targetRange = dict.Item(varKey) & unusedRow
ws.Range(targetRange) = ws2.Range(orignRange)
Next
Response = MsgBox("Data were exported successfully", vbOKOnly, "Success")
End If
Next i
End If
ExitSub:
Set dict = Nothing
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set ws2 = Nothing
excelWorkbookMail.Close (False)
Set excelWorkbookMail = Nothing
Set ws = Nothing
excelWorkbookHD.Close (True)
Set excelWorkbookHD = Nothing
End Sub
Gruß Steffen