Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
792to796
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
792to796
792to796
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Nur neue Kontakte aus Excel an Outlook senden?

Nur neue Kontakte aus Excel an Outlook senden?
22.08.2006 15:36:40
Kasimir
Hallo an alle!
Ich hätte da mal eine Frage. Mit nachfolgenden Makro (habe ich in der Recherche gefunden) übertrage ich Kontaktdaten aus Excel nach Outllook.
Sub Adressen_Tabelle1()
    Dim Outlook As Outlook.Application
    Dim Outlookname As Outlook.Namespace
    Dim Kontaktordnernummer As Outlook.MAPIFolder
    Dim Outlookkontakt As Outlook.ContactItem
    Dim Eintragnummer As Integer
    If ActiveSheet.Name = "Tabelle1" Then
    Set Outlook = CreateObject("Outlook.Application")
    Set Outlookname = Outlook.GetNamespace("MAPI")
    Set Kontaktordnernummer = Outlookname.Folders(2).Folders("Kontakte")
        For Eintragnummer = 3 To Cells(Rows.Count, 6).End(xlUp).Row
            If Cells(Eintragnummer, 6) <> "" Then
            Set Outlookkontakt = Kontaktordnernummer.Items.Add
            'Firmenname
            Outlookkontakt.CompanyName = Range("C" & Eintragnummer).Value
            'Anrede
            Outlookkontakt.Title = Range("D" & Eintragnummer).Value
            'Nachname
            Outlookkontakt.LastName = Range("F" & Eintragnummer).Value
            'Vorname
            Outlookkontakt.FirstName = Range("G" & Eintragnummer).Value
            'Strasse
            Outlookkontakt.BusinessAddressStreet = Range("I" & Eintragnummer).Value
            'Postleitzahl
            Outlookkontakt.BusinessAddress = Range("J" & Eintragnummer).Value
            'Stadt
            Outlookkontakt.BusinessAddressCity = Range("K" & Eintragnummer).Value
            'Firmentelefonnummer
            Outlookkontakt.BusinessTelephoneNumber = Range("L" & Eintragnummer).Value
            'Mobilfunknummer
            Outlookkontakt.MobileTelephoneNumber = Range("M" & Eintragnummer).Value
            'Faxnummer
            Outlookkontakt.BusinessFaxNumber = Range("N" & Eintragnummer).Value
            'Homepage
            Outlookkontakt.BusinessHomePage = Range("O" & Eintragnummer).Value
            'E-Mailadresse
            Outlookkontakt.Email1Address = Range("P" & Eintragnummer).Value
            'Bemerkungen
            Outlookkontakt.Body = Range("Q" & Eintragnummer).Value
            'Geburtstag
            Outlookkontakt.Birthday = Range("Z" & Eintragnummer).Value
            'Kontakteintrag in Outlook speichern
            Outlookkontakt.Save
            Set Outlookkontakt = Nothing
        End If
        Next
    Set Kontaktordnernummer = Nothing
    Set Outlookname = Nothing
    Set Outlook = Nothing
    End If
End Sub
Das funktioniert alles wunderbar. Allerdings hat die ganze Sache einen Haken. Besteht bereits ein Kontakt, wird dieser erneut angelegt. Gibt es eine Möglichkeit dieses zu verhindern, so dass nur Kontakte, die es noch nicht in dem Outlookadressbuch gibt, übertragen werden?
Danke Euch für die Hilfe und Gruß,
Kasimir

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Nur neue Kontakte aus Excel an Outlook senden?
22.08.2006 22:21:09
bst
Abend Kasimir,
an Hand welcher Kriterien willst Du denn festlegen ob's denn Kontakt bereits gibt ?
cu, Bernd
AW: Nur neue Kontakte aus Excel an Outlook senden?
23.08.2006 10:35:58
Kasimir
Hallo Bernd,
danke Dir für Deine Antwort, aber ich bin zwischenzeitlich in der Recherche auf eine Funktion gestossen, die prüft, ob ein Kontakt bereits enthalten ist. Wenn nicht, wird er angelegt, wenn doch, wird der Kontakt übersprungen. Nachfolgend der Coe, wie er im Moment bei mir funktioniert:
Sub Kontakte_Tabelle1()
   Dim Blatt As Worksheet, Eintragnummer As Integer
   Dim Outlookprogramm As Object, Outlookkontakt As Object
   
   'Wo stehen die Kontaktdaten
   Set Blatt = Worksheets("Tabelle3")
   'Outlook Objekt erstellen
   Set Outlookprogramm = CreateObject("Outlook.Application")
   'Mit "With" wird auf das Tabellenobjekt referenziert
   With Blatt
      'Zählschleife starten
      'Dazu wird der letzten Eintrag in Spalte A bestimmt
      'Der Adressenbereich beginn in Zeile 2
      'deshalb startet auch die Zählschleife dort
        For Eintragnummer = 3 To .Cells(Rows.Count, 6).End(xlUp).Row
        Application.StatusBar = Eintragnummer & " Adresse(n) von " & .Cells(Rows.Count, 6).End(xlUp).Row & " bereits verarbeitet."
         'Outlook Kontaktobject suchen bzw. neu erstellen
         Set Outlookkontakt = Kontakt_erstellen(Outlookprogramm, .Cells(Eintragnummer, 6).Value, .Cells(Eintragnummer, 7).Value)
         'Eine vollständige Liste der möglichen Felder
         'finden Sie in der Outlook-VBA-Hilfe
            'Firmenname
            Outlookkontakt.CompanyName = .Range("C" & Eintragnummer).Value
            'Anrede
            Outlookkontakt.Title = .Range("D" & Eintragnummer).Value
            'Strasse
            Outlookkontakt.BusinessAddressStreet = .Range("I" & Eintragnummer).Value
            'Postleitzahl
            Outlookkontakt.BusinessAddress = .Range("J" & Eintragnummer).Value
            'Stadt
            Outlookkontakt.BusinessAddressCity = .Range("K" & Eintragnummer).Value
            'Firmentelefonnummer
            Outlookkontakt.BusinessTelephoneNumber = .Range("N" & Eintragnummer).Value
            'Mobilfunknummer
            Outlookkontakt.MobileTelephoneNumber = .Range("O" & Eintragnummer).Value
            'Faxnummer
            Outlookkontakt.BusinessFaxNumber = .Range("P" & Eintragnummer).Value
            'Homepage
            Outlookkontakt.BusinessHomePage = .Range("Q" & Eintragnummer).Value
            'E-Mailadresse
            Outlookkontakt.Email1Address = .Range("R" & Eintragnummer).Value
            'Bemerkungen
            Outlookkontakt.Body = .Range("S" & Eintragnummer).Value
            'Geburtstag
            Outlookkontakt.Birthday = .Range("AB" & Eintragnummer).Value
            'Kontakteintrag in Outlook speichern
            Outlookkontakt.Save
         
         'Object entfernen
         Set Outlookkontakt = Nothing
      Next Eintragnummer
   End With
   Set Outlookprogramm = Nothing
Application.StatusBar = ""
End Sub
Function Kontakt_erstellen(Outlookprogramm As Object, LastName As String, FirstName As StringAs Object
   Dim Kontaktordner As Object, item As Object
   
   ' öffnet den Standard-Kontaktordner, 10 = olFolderContacts
   Set Kontaktordner = Outlookprogramm.GetNamespace("MAPI").GetDefaultFolder(10)
   ' durchsucht dort alle Kontakte
   For Each item In Kontaktordner.Items
      ' Falls Vor- und Nachname übereinstimmen wird dieser Kontakt zurückgegeben
      If UCase(item.LastName) = UCase(LastName) And UCase(item.FirstName) = UCase(FirstName) Then
         Set Kontakt_erstellen = item
         Exit Function
      End If
   Next
   ' Kein passender Kontakt gefunden, einen neuen Kontakt erstellen
   Set Kontakt_erstellen = Outlookprogramm.CreateItem(2)
   ' Und dann noch die Namen eintragen
   Kontakt_erstellen.LastName = LastName
   Kontakt_erstellen.FirstName = FirstName
End Function
Eventuell kann ja jemand anderes den Code noch mal gebrauchen.
Nochmal besten Dank und Gruß,
Kasimir
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige