Makros anpassen, zuweisen pro sheet
06.04.2018 08:30:38
Hannes
In dem Markro kann man aus einer Excel Tabelle eine Aufgabe in Outlook mit Kategorie und Farbe erstellen abhängig von Zellranges.
Alles funktioniert wie es soll jedoch besteht noch ein kleines Problem.
Kann man das Makro auch so anpassen das es nur für bestimmte Arbeitsblätter geht?
Beispiel in sheet1 kann ich nun meine Zellranges zur Kategorie und Farbe anpassen so wie ich es wollte. Damit ist das Makro zugeschnitz. In sheet2 im selben Dokument kann ich das makro aber nicht verwenden weil unter diesen Zellranges sich andere Kategorien und Farben verbergen sollen.
Gibt es eine Moglichkeit den makros ein sheet zuzuweisen im selben Dokument?
Danke ;-)
Option Explicit
'Farben für Kategorie
Enum enuCatColor
schwarz = 15
Blau = 8
Dunkelblau = 23
Dunkelgrau = 14
Dunkelgrün = 20
Dunkles_Kastanienbraun = 25
Dunkles_Olivgrün = 22
Dunkelorange = 17
Pfirsich_dunkel = 18
Dunkles_Lila = 24
Dunkelrot = 16
Dunkles_Stahlblau = 12
Dunkles_Blaugrün = 21
Dunkelgelb = 19
Grau = 13
Grün = 5
braun = 10
Keine_Farbe = 0
Olivgrün = 7
Orange = 2
Pfirsichfarbe = 3
Violett = 9
Rot = 1
stahlblau = 11
Blaugrün = 6
Gelb = 4
End Enum
Sub ImportAufgabeOutlook1()
Dim oOutlookApp As Object, oAufgabe As Object
Dim Mapi As Object, oCat As Object, eFarbe As enuCatColor
'Hier Farbe anpassen
eFarbe = 1
'Verbindung/Referenz zu Outlook
Set oOutlookApp = CreateObject("Outlook.Application")
'Kategorie
Set Mapi = oOutlookApp.GetNamespace("Mapi")
If Range("C1").Value "" Then
For Each oCat In Mapi.Categories
If oCat.Name = Range("C1").Value Then
Exit For
End If
Next
If oCat Is Nothing Then
Set oCat = Mapi.Categories.Add(Range("C1").Value)
End If
oCat.Color = eFarbe
End If
'Termin erzeugen
Set oAufgabe = oOutlookApp.CreateItem(3)
'Termin Einstellungen vornehmen
With oAufgabe
'Starttermin (hier bswp.: Heute in 14 Tagen um 10 Uhr)
.StartDate = Format(Now() + 14, "dd.mm.yyyy") & " 10:00"
'Betreff, Titel
.Subject = Range("C1") & " " & Range("B5")
'Falligkeit am
.DueDate = Range("G5")
'Inhalt
.Body = Range("B5") & " " & Range("G5")
'Kategorie
.Categories = Range("C1").Value
'Erinnerung setzen
.ReminderTime = Range("G5") - 7 & " 10:00"
.ReminderSet = True
'Speichern
.Save
'Anzeigen
.Display
End With
Set oAufgabe = Nothing
Set oOutlookApp = Nothing
End Sub