Makro soll Dateien aus Outlook zusammenhängen

Guten Tag miteinander
Mal wieder bin ich auf Eure Hilfe sehr angewiesen.
Es geht diesmal um Folgendes Vorhaben (bei dem ich bisher keine Ahnung hab, wie ich das angehen soll):
In verschiedenen Emails welche in Outlook reinkommen gibt es mehrere xlsx Dateianhänge (unterschiedliche Dateinamen, aber immer gleicher File-Aufbau)
Ich muss nun eine VBA-Funktion/Makro erstellen, welches mir per Mausklick aus dem aktuell geöffneten Email raus alle Dateianhänge öffnet und zu einer einzigen, neuen Datei zusammenhängt.
Dabei reicht es völlig aus, wenn bloss aus jeder Datei die Spalte G und Spalte M geholt wird.
Ziel: Ein neues File, welches einen kompletten Zusammenzug aller File-Inhalte des aktuellen Emails enthält.
Geht sowas ?
Anbei mal eine Musterdatei, die den Aufbau der Datei-Anhänge zeigt:
https://www.herber.de/bbs/user/89831.xlsx
Ich bin Euch für jegliche Unterstützung herzlich dankbar!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Pascal,
der Code müsste funktionieren, ich habe mich nicht gross mit einer Fehlerbehebung beschäftigt, das überlasse ich getrost dir.

Sub AnhängeSpeichern()
Dim mail As Object
Dim xl As Object
Dim arrG() As Variant
Dim arrM() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim Pfad As String
Set mail = Application.ActiveExplorer.Selection(1)
Set xl = CreateObject("Excel.Application")
Pfad = "C:\Temp\" 'hier einen Pfad eingeben, in dem die Dateien temporär gespeichert werden.  _
Pfad vorher anlegen!
On Error GoTo Fehler
With mail
With .Attachments
If .Count > 0 Then
ReDim arrG(.Count)
ReDim arrM(.Count)
j = 0 'Array beginnt bei 0
For i = 1 To .Count
If Right(.Item(i).FileName, 5) = ".xlsx" Then
.Item(i).SaveAsFile Pfad & .Item(i).FileName
xl.workbooks.Open FileName:=Pfad & .Item(i).FileName
With xl.activeworkbook.activesheet
arrG(j) = .Range("G:G") 'Gesamte Spalte einlesen, da ich keine Mö _
glichkeit kenn die letzte Zeile ausfindig zu machen ohne die Excel Bibliothek mit einzubinden
arrM(j) = .Range("M:M")
End With
xl.activeworkbook.Close 'Workbook wieder schliessen
Kill Pfad & .Item(i).FileName 'Temporäre Datei wieder löschen
j = j + 1
End If
Next i
ReDim Preserve arrG(j - 1) 'j-1 damit das Array nur die Grösse der effektiven Daten  _
hat
ReDim Preserve arrM(j - 1)
'Die Daten in ein neues WB schreiben
xl.workbooks.Add
With xl.activeworkbook.activesheet
For i = 0 To UBound(arrM)
For j = 1 To UBound(arrM(i))
If arrG(i)(j, 1)  "" Then
k = k + 1
.cells(k, 1) = arrG(i)(j, 1)
.cells(k, 2) = arrM(i)(j, 1)
Else: Exit For
End If
Next j
Next i
.SaveAs Pfad & Date & ".xlsx"
xl.Quit
Exit Sub
End With
End If
End With
End With
Fehler:
xl.Quit
MsgBox "Irgendwas hat leider nicht geklappt"
End Sub

Hoffe es hilft dir.
Gruess
Raphael

Beliebteste Forumthreads (12 Monate)

Makro soll Dateien aus Outlook zusammenhängen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread