Outlook'tan Excel'e tablo kopyalama

[qazxswedc321]

Herkese merhaba,
Konu biraz karışık, umarım net olarak anlatabilmişimdir; şöyle ki:

Microsoft Outlook'ta belirli bir adresten gelen e-postaların bazıları, ek olarak değil de e-postanın gövdesinde tablo içermektedir. Bu tablo excel'de hazırlanıp e-posta'ya yapıştırılmıştır. Bu tablonun bazı satırlarında hücre birleştirmeler yapılmıştır, bu nedenle direkt olarak net bir şekilde sütun sayısını vermek doğru olmayabilir. Bu gelen e-postalar yine aynı gönderici tarafından yanıtlanarak tablo içermeyen başka bilgiler de içerebilmektedir (aynı gönderici tarafından yanıtlandığında e-postanın konu kısmı "RE: " ile başlamaktadır). Yapmak istediğim; belirli bir tarih aralığında (genellikle aylık bazda) belirli bir adresten gelen e-postaların konu kısmı "RE: " ile başlamıyorsa ve e-posta gövdesi tablo içeriyorsa bu tabloları tek bir excel sayfasına tablolar arası bir satır boşluk bırakarak ve alt alta gelecek şekilde kopyalamak. Bu tabloların tamamı ortak hücre bilgileri içermektedir; örneğin 'Araba Markası:', 'Araba Rengi' gibi. Ayrıca tabloyu kopyalarken o tablonun yer aldığı e-postanın alınma tarihini de kopyalamak istiyorum.
Bunu nasıl yapabilirim bilmiyorum.

Yardımcı olabilirseniz çok sevinirim.

Saygılarımla

 

[pitchoute]

Deneyip sonucu paylaşabilir misiniz;

Sub ExtractTablesToExcel()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim olItem As Object
    Dim i As Long
    Dim sSender As String
    Dim dtStart As Date, dtEnd As Date
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlRow As Long
    Dim wdDoc As Word.Document
    Dim wdTable As Word.Table
    Dim tCount As Long
    dtStart = DateSerial(2023, 10, 1)  ' Başlangıç tarihi (örn: 1 Ekim 2023)
    dtEnd = DateSerial(2023, 10, 31)   ' Bitiş tarihi (örn: 31 Ekim 2023)
    sSender = "gonderici@example.com"   ' Buraya göndericinin e-posta adresini yazın
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
   
    Dim filter As String
    filter = "[ReceivedTime] >= '" & Format(dtStart, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(dtEnd + 1, "ddddd h:nn AMPM") & "'"
    Set olItems = olFolder.Items.Restrict(filter)
    olItems.Sort "[ReceivedTime]", True
   
    Set xlApp = New Excel.Application
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    Set xlSheet = xlWB.Sheets(1)
    xlRow = 1 
    For Each olItem In olItems
        If TypeOf olItem Is MailItem Then
            Set olMail = olItem
            If LCase(olMail.SenderEmailAddress) = LCase(sSender) Then
                If Left(olMail.Subject, 4) <> "RE: " Then
                    Set wdDoc = olMail.GetInspector.WordEditor
                    tCount = wdDoc.Tables.Count
                    If tCount > 0 Then
                        xlSheet.Cells(xlRow, 1).Value = "E-posta Alınma Tarihi: " & olMail.ReceivedTime
                        xlRow = xlRow + 1
                        For i = 1 To tCount
                            Set wdTable = wdDoc.Tables(i)
                            wdTable.Range.Copy
                            xlSheet.Cells(xlRow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                            xlRow = xlSheet.Cells(xlSheet.Rows.Count, 1).End(xlUp).Row + 2
                        Next i
                    End If
                End If
            End If
        End If
    Next olItem

    Set wdDoc = Nothing
    Set olMail = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    xlWB.SaveAs "C:\DosyaYolu\DosyaAdi.xlsx"
    xlWB.Close
    xlApp.Quit
    Set xlSheet = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
   
    MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[qazxswedc321]

Merhaba,

Kodu çalıştırdım, boş bir excel sayfası açıldı, tabloları excel sayfasına kopyalamadı.

E-posta'larda olması gereken tablo aşağıdaki şekilde; bu tabloda hem satır hem de sütun olarak birleşik hücreler var, ancak buraya kopyalarken onları gösteremedim. Ayrıca hata sırası 3 madde ile sınırlı değil, artabiliyor veya azalabiliyor.

Müşteri:		Takım Giriş Saati:		Üretim Hattı:
Araç No :
Toplam Oturum :		Takım Çıkış Saati :		Teslim Alınan Oturum:
Dosya Kontrolü :		İlave Malzeme:
Hata Sırası	Hata Tanımı	Hata Adeti	Hata Kodu	Giderilme Durumu	Operatör No
1
2
3