tsunami87
Goto Top

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

Content-Key: 228894

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

Ausgedruckt am: 19.03.2024 um 10:03 Uhr

Mitglied: colinardo
Lösung colinardo 06.02.2014, aktualisiert am 10.02.2014 um 09:56:26 Uhr
Goto Top
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
Mitglied: Tsunami87
Tsunami87 06.02.2014 um 12:20:05 Uhr
Goto Top
Hallo Uwe,

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

Grüße
René
Mitglied: colinardo
colinardo 06.02.2014 aktualisiert um 12:25:23 Uhr
Goto Top
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 face-wink

Grüße Uwe
Mitglied: Tsunami87
Tsunami87 10.02.2014 um 06:53:22 Uhr
Goto Top
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é
Mitglied: colinardo
colinardo 10.02.2014 um 08:43:28 Uhr
Goto Top
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
Mitglied: Tsunami87
Tsunami87 10.02.2014 um 09:56:11 Uhr
Goto Top
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 face-smile

Vielen Dank.

Grüße
René
Mitglied: colinardo
colinardo 10.02.2014 aktualisiert um 10:05:17 Uhr
Goto Top
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