Mail

[erdalerolayas]

Gelen Kutsunda MAL GİRİŞİ klasöründe Mal Girişi Bilgilendirme konulu maillerin içinde tabloları excel çekmek istedim. kodu yazdım ama tüm mailleri kontrol edemiyor.
kodu neresinde eksik var yardımcı olabilecek var mı?
Sub TablolariExcelAktar()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olInspector As Outlook.Inspector
Dim olWord As Object
Dim olDoc As Object
Dim tblRange As Object
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelWorksheet As Object
Dim pasteRange As Object
Dim mailCount As Long
Dim rowCounter As Long
Dim oldestDate As Date

' Outlook uygulamasını başlat
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")

' "MAL GİRİŞİ" klasörünü bul
Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("MAL GİRİŞİ") ' Klasör adını değiştirin

' En eski tarihi bul
oldestDate = Now

' "MAL GİRİŞİ" klasöründeki tüm mailleri kontrol et
For Each olItem In olFolder.Items
If olItem.Subject = "Mal girişi bilgilendirmesi" Then
' E-postanın tarihini kontrol et
If olItem.ReceivedTime < oldestDate Then
oldestDate = olItem.ReceivedTime
End If
End If
Next olItem

' Excel uygulamasını başlat
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True

' Yeni bir Excel çalışma kitabı oluştur
Set excelWorkbook = excelApp.Workbooks.Add
Set excelWorksheet = excelWorkbook.Worksheets(1)

' Excel çalışma sayfasında başlıkları ayarla
excelWorksheet.Cells(1, 1).Value = "Malzeme Belge No"
excelWorksheet.Cells(1, 2).Value = "Belge Yılı"
excelWorksheet.Cells(1, 3).Value = "Satır No"
excelWorksheet.Cells(1, 4).Value = "Belge Tarihi"
excelWorksheet.Cells(1, 5).Value = "Kayıt Tarihi"
excelWorksheet.Cells(1, 6).Value = "Malzeme Numarası"
excelWorksheet.Cells(1, 7).Value = "Malzeme Metni"
excelWorksheet.Cells(1, 8).Value = "Üretim Yeri"
excelWorksheet.Cells(1, 9).Value = "Depo Yeri"
excelWorksheet.Cells(1, 10).Value = "Satıcı"
excelWorksheet.Cells(1, 11).Value = "Miktar"
excelWorksheet.Cells(1, 12).Value = "ÖB"
excelWorksheet.Cells(1, 13).Value = "SAS No"
excelWorksheet.Cells(1, 14).Value = "SAT No"

' İşlenen e-posta sayacı
mailCount = 2

' "MAL GİRİŞİ" klasöründeki tüm mailleri kontrol et
For Each olItem In olFolder.Items
If olItem.Subject = "Mal girişi bilgilendirmesi" And olItem.ReceivedTime = oldestDate Then
' E-postanın içeriğini aç
Set olInspector = olItem.GetInspector
Set olWord = olInspector.WordEditor
Set olDoc = olWord.Application.ActiveDocument

' İlk tabloyu bul ve metin olarak kopyala
If olDoc.Tables.Count > 0 Then
Set tblRange = olDoc.Tables(1).Range
tblRange.Copy

' Excel'e yapıştır
rowCounter = excelWorksheet.Cells(excelWorksheet.Rows.Count, 1).End(-4162).Row + 1 ' Son boş satırı bul
excelWorksheet.Cells(rowCounter, 1).PasteSpecial xlPasteValues
mailCount = mailCount + tblRange.Rows.Count - 1 ' Başlık satırını saymamak için -1

' Tablonun başlıklarını tekrar ayarla
For i = 1 To 14
excelWorksheet.Cells(1, i).Copy
excelWorksheet.Cells(rowCounter, i).PasteSpecial xlPasteFormats
Next i
End If
End If
Next olItem

' Belleği temizle
Set olApp = Nothing
Set olNamespace = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set olInspector = Nothing
Set olWord = Nothing
Set olDoc = Nothing
Set tblRange = Nothing
Set excelApp = Nothing
Set excelWorkbook = Nothing
Set excelWorksheet = Nothing
Set pasteRange = Nothing

MsgBox "En eski tarihe sahip tablo başarıyla Excel'e aktarıldı!", vbInformation
End Sub