Feb 06, 2014, updated at 09:40:22 (UTC)

8502

Makro: Terminübergabe von Excel nach Outlook

Hallo liebe Gemeinde,

Aufgabenstellung war eine Lösung zu finden was Daten aus Excel in eine Outlookaufgabe schreibt.
Eine Lösung habe ich mir mit Office 2013 und dem Internet zusammengeschustert.

Meine Tabelle sieht grob so aus

A	B	C	D	E
Lieferant	Art. No.	Artikel	Prod.Gruppe	Datum

Mit diesemMakro funktioniert dies auch wunderbar.

Option Explicit

Sub AufgabenNachOutlook()
'Variablen deklarieren.  
Dim appOutLook As Outlook.Application
Dim taskOutLook As Outlook.TaskItem
'Dim mydelegate As Outlook.Recipient  
    
    'Mit Zelle "E4" beginnen, In Spalte E steht das Datum  
Range("E4").Select  

    'Wiederhole solange bis eine Zelle in Spalte H leer ist  
Do Until ActiveCell.Value = ""  

    'Prüfen ob in Spalte 41 ein x ist,  
    'dass bedeutet, dass der Termin schon einmal erfasst wurde  
    'Wenn ein x vorhanden ist, dann zur Sprungmarke AufgabeDa gehen  

If ActiveCell.Offset(0, 36).Value = "x" Then GoTo AufgabeDa  

    'Verbindung zu Outlook herstellen.  
Set appOutLook = CreateObject("Outlook.Application")  
    'Ankündigen, dass eine Aufgabe erstellt werden soll.  
Set taskOutLook = appOutLook.CreateItem(olTaskItem)

    With taskOutLook
        'Set mydelegate = taskOutLook.Recipients.Add("mail@irgendwas.de")  
        'Betreff einfügen.  
        .Subject = "INDEX" & " " & ActiveCell.Offset(0, -1)  
        'Text für die Aufgabe eintragen.  
        .Body = ActiveCell.Offset(0, -3) & " / " & ActiveCell.Offset(0, -2)  
        'Datum für den Beginn setzen.  
        .StartDate = Format(ActiveCell.Value, "dd.mm.yyyy")  
        'Erinnerungszeit setzen.  
        .ReminderTime = Format(ActiveCell.Value - 21, "dd.mm.yyyy") & " " & "01:00"  
        'Erinnerung einschalten.  
        .ReminderSet = True
        'Aufgabe speichern.  
        .Save
        'Aufgabe öffnen.  
        .Display ' Wenn die Aufgaben nicht geöffnet werden sollen, dann einfach auskommentieren  

    End With

    ' In die 41. Spalte ein x setzen heißt:  
    ' der Termin wurde schon einmal in den Kalender eingetragen  
    ' Deshalb den Code ab hier weiter abarbeiten  
ActiveCell.Offset(0, 36).Value = "x"  

    'Sprungmarke  
AufgabeDa:


    'Nächste Zeile der gleichen Spalte auswählen  
ActiveCell.Offset(1, 0).Select

    ' Verbindung zu Outlook trennen  
Set taskOutLook = Nothing
Set appOutLook = Nothing

'Nächster Schleifendurchlauf  
Loop

MsgBox "Alle Aufgaben wurden in Outlook eingetragen!"  

End Sub

Neue Aufgabe zu diesem Makro / Tabelle:
Prod.Gruppen mit selbem Datum zusammenfassen und die Artikelbeschreibungen in den Text der Aufgabe schreiben.
Bsp. Tabelle

A	B	C	D	E
Lieferant	Art. No.	Artikel	Prod.Gruppe	Datum
Hr. X	00615	Kette w	Fahrrad	30.01.2014
Hr. X	00815	Kette y	Fahrrad	30.01.2014
Hr. Y	00724	Helm y	Fahrrad	28.02.2014
Hr. X	00915	Kette z	Fahrrad	30.01.2014
Hr. Y	00624	Helm x	Fahrrad	28.02.2014
Hr. Y	00824	Helm z	Fahrrad	30.02.2014
Hr. X	00715	Kette x	Fahrrad	30.01.2014

Bsp. Aufgabe im Outlook

Betreff: Index Fahrrad
Fälligkeitsdatum: 30.01.2014
Erinnerung: 09.01.2014
Text: 00615 / Kette w    
      00715 / Kette x           
      00815 / Kette y
      00915 / Kette z

Betreff: Index Fahrrad
Fälligkeitsdatum: 28.02.2014
Erinnerung: 07.01.2014
Text: 00624 / Helm x    
      00724 / Helm y           

Wie kann ich dies am besten umsetzen? Wäre für jede Hilfe sehr dankbar.

Mit freundlichen Grüßen
Tsunami

Please also mark the comments that contributed to the solution of the article

Content-Key: 228894

Url: https://administrator.de/contentid/228894

Printed on: April 19, 2024 at 00:04 o'clock

7 Comments

Latest comment

Hallo Tsunami,
schau dir am besten dieses Demo-Sheet dazu an.
Es sortiert die Tabelle nach Datum und erstellt dann die Tasks gruppiert nacheinander.

Grüße Uwe

Hallo Uwe,

vielen Dank für deine Antwort.
Ich werde dies gleich einmal verbauen.

Grüße
René

Nur zur Info falls ein Fehler auftreten sollte ...darüber bin ich gestolpert:
In deinen Demo-Daten war ein 30.02.2014 vorhanden. Dieser Tag im Februar existiert aber nicht

Grüße Uwe

Morgen Uwe,

bitte Entschuldige die späte Rückantwort.

Das Makro sieht nun so aus:

 
Sub AufgabenNachOutlookGruppe()

   Dim rngStart As Range, rngEnd As Range, cell As Range, sheet As Worksheet, taskOutlook As Variant
    Set appOutLook = CreateObject("Outlook.Application")  
    Set sheet = Worksheets(2)
   Set rngStart = sheet.Range("A4")  
    Set rngEnd = rngStart.End(xlDown)
    


   sheet.Range(rngStart, rngEnd.Offset(0, 14)).Sort Key1:=Range("H3"), Order1:=xlAscending, Key2:=Range("E3"), Order2:=xlAscending  
    prev_date = ""  
    prev_group = ""  

    For Each cell In sheet.Range(rngStart, rngEnd)

    If cell.Offset(0, 18).Value = "x" Then GoTo AufgabeDA  
        art_date = cell.Offset(0, 7).Value
        art_group = cell.Offset(0, 4).Value
        
        If prev_date = art_date And prev_group = art_group Then
            taskOutlook.Body = taskOutlook.Body & cell.Offset(0, 1).Value & " / " & cell.Offset(0, 3).Value & vbNewLine  
    
        Else
            Set taskOutlook = appOutLook.CreateItem(3)
            With taskOutlook
                'Betreff einfügen.  
                .Subject = "INDEX " & cell.Offset(0, 4).Value  
                'Text für die Aufgabe eintragen.  
                .Body = cell.Offset(0, 1).Value & " / " & cell.Offset(0, 3).Value & vbNewLine  
                'Datum für den Beginn setzen.  
                .StartDate = DateValue(cell.Offset(0, 7).Value)
                'Erinnerungszeit setzen.  
                .ReminderTime = DateAdd("d", -21, .StartDate) & " 01:00"  
                'Erinnerung einschalten.  
                .ReminderSet = True
                'Aufgabe speichern.  
                '.Save  
                'Aufgabe öffnen.  
                .Display ' Wenn die Aufgaben nicht geöffnet werden sollen, dann einfach auskommentieren  
            End With
           prev_date = art_date
           prev_group = art_group
        End If
cell.Offset(0, 18).Value = "x"  
AufgabeDA:
    Next
    Set appOutLook = Nothing
End Sub

Funktioniert super, leider erhalte bei der letzten Zeile "Typen unverträglich" ist es möglich einen Befehl ähnlich

Do Until ActiveCell.Value = ""

Grüße
René

Hallo René,

leider erhalte bei der letzten Zeile "Typen unverträglich"

das hilft jetzt nicht so wirklich, bei End Sub wird der Fehler sicher nicht liegen. Kenne deinen Tabelleninhalt jetzt nicht, aber der Code in Zeile 8 legt ja die Zelle fest in der als letztes ein Wert in Spalte A eingetragen ist. Wenn du eine andere Zelle auf vorhandensein eines Wertes prüfen willst kannt du das vor der Zeile 18 mit

if cell.Offset(0,4).Value <> "" then Exit For

machen (Offset an die zu überprüfende Zelle anpassen). Dann springt er aus der Schleife und beendet die Prozedur.
Hoffe das hilft die weiter.

Grüße Uwe

Hallo Uwe,

nicht ganz.
Ich glaube der fehler erscheint da keine Werte in der Spalte stehen.
Aber damit kann ich leben.

Vielleicht finde ich noch was

Vielen Dank.

Grüße
René

arbeite mit dem Debugging und Schritt-für-Schritt Ausführung (F8), setze Breakpoints und Variablenüberwachung in deinem Code, dann findest du den Übeltäter 100%.
Und den Sprung mit der Goto-Marke würde ich durch eine If-Abfrage ersetzen...

Grüße Uwe

German solved Question Microsoft Office Microsoft

Hotly discussed

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments

WIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 1 Comment

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment