Outlook Adres Defterine Excel'den Kişi Ekle (Makro ile)

[b]Excel[/b]'deki rehber tablonuzu bu şekilde hazırlayıp, aşağıdaki kodlar ile Adres defterinize [b]Excel[/b]'den kişi eklemesi yapabilirsiniz...

' Excel sayfa başlıkları:
    '1. satırda başlıklar...
    ' A sütunu: Adı
    ' B sütunu: Soyadı
    ' C sütunu: Email
    ' D sütunu: Firma
    ' E sütunu: İş tel
    ' F sütunu: İş Fax
    ' G sütunu: Ev tel
    ' H sütunu: Cep tel

■ [b]Bu kodları kullanabilirsiniz;[/b]

Dim ExcelOUT As Boolean
Rem Www.ExcelVBA.Net

Sub OutlookaExceldenAdresEkle()
    Dim ekle As Boolean
    ekle = ExcelAdresEkle
End Sub

Function ExcelAdresEkle() As Boolean    
    On Error GoTo Hata
    
    Dim Satir As Long, Sutun As Long, Say As Long, KisiDetay As Variant
    Dim ExcelKisi As Object, Kisi_ad As String, Kisi_soyad As String
    Dim Kisi_mail As String, Kisi_firma As String, Kisi_firma_tel As String
    Dim Kisi_firma_fax As String, Kisi_ev_tel As String, Kisi_cep_tel As String
    
    Satir = Sayfa1.Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Count
    Sutun = Sayfa1.Range(Range("A1"), Range("IV1").End(xlToLeft)).Count
    ReDim KisiDetay(1 To Satir, 1 To Sutun)
    
    KisiDetay = Range(Cells(2, 1), Cells(Satir + 1, Sutun))
    
    Dim olApp As Object ' Outlook.Application
    Set olApp = VBA.CreateObject("Outlook.Application") ' GetOutlookApp
    
    Say = 1
    
    Do Until Say = Satir
    
      Kisi_ad = KisiDetay(Say, 1)
      Kisi_soyad = KisiDetay(Say, 2)
      Kisi_mail = KisiDetay(Say, 3)
      Kisi_firma = KisiDetay(Say, 4)
      Kisi_firma_tel = KisiDetay(Say, 5)
      Kisi_firma_fax = KisiDetay(Say, 6)
      Kisi_ev_tel = KisiDetay(Say, 7)
      Kisi_cep_tel = KisiDetay(Say, 8)
    
      Set ExcelKisi = olApp.CreateItem(2)
    
      With ExcelKisi
        .FirstName = Kisi_ad
        .LastName = Kisi_soyad
        .Email1Address = Kisi_mail
        .CompanyName = Kisi_firma
        .BusinessTelephoneNumber = Kisi_firma_tel
        .BusinessFaxNumber = Kisi_firma_fax
        .HomeTelephoneNumber = Kisi_ev_tel
        .MobileTelephoneNumber = Kisi_cep_tel
      End With
    
      ExcelKisi.Close 0 '
      Say = Say + 1
    Loop
    
    ExcelAdresEkle = True
    GoTo Bitir
    
Hata:
    ExcelAdresEkle = False
    
Bitir:
    Set ExcelKisi = Nothing
    If ExcelOUT Then
      olApp.Quit
    End If
    Set olApp = Nothing
End Function

Function GetOutlookApp() As Object
    On Error Resume Next
    Set GetOutlookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set GetOutlookApp = CreateObject("Outlook.Application")
        ExcelOUT = True
    End If
    On Error GoTo 0
End Function

Hoşça kalın !