Excel vba電子メール本文に特定のテキストをコピーする

Question

このWebサイトでは、outlookの指定されたフォルダから電子メール本文をコピーし、それをExcelに貼り付ける以下のコードが見つかりました。しかし、問題は、特定のテキストのみをExcelにコピーすることです。電子メールのサンプルを挿入しました。強調表示された項目をコピーします。参考までに、数字の位置はメールごとに異なります。例えば。 "バッチ番号12345678"; "Bnumber 12345678"; "Bの＃87654321"; "BTの＃12345678"

CODE：

Option Explicit 
    Public gblStopProcessing As Boolean 
    Sub ParseBlockingSessionsEmailPartOne() 
    ' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim objFolder As Object 
    Dim objNSpace As Object 
    Dim objOutlook As Outlook.Application 
    Dim lngAuditRecord As Long 
    Dim lngCount As Long 
    Dim lngTotalItems As Long 'Count of emails in the Outlook folder. 
    Dim lngTotalRecords As Long 
    Dim i As Integer 
    Dim EmailCount As Integer 'The counter, which starts at zero. 
    ' 
    On Error GoTo HandleError 
    'Application.ScreenUpdating = True 
    'Application.ScreenUpdating = False 
    ' 
    Sheets("Merge Data").Select 
    ' 
     ' Initialize: 
     Set wb = ThisWorkbook 
     lngAuditRecord = 1 ' Start row 
     lngTotalRecords = 0 
    ' 
     ' Read email messages: 
     Application.ScreenUpdating = False 
     Set objOutlook = CreateObject("Outlook.Application") 
     Set objNSpace = objOutlook.GetNamespace("MAPI") 
    ' 
     ' Allow user to choose folder:# 
     Set objFolder = objNSpace.pickfolder 
     ' Check if cancelled: 
     If objFolder Is Nothing Then 
      gblStopProcessing = True 
      MsgBox "Processing cancelled" 
      Exit Sub 
     End If 
    ' 
     lngTotalItems = objFolder.Items.Count 
     If lngTotalItems = 0 Then 
      MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder" 
      gblStopProcessing = True 
      GoTo HandleExit 
     End If 
     If lngTotalItems > 0 Then 
      On Error Resume Next 
       Application.DisplayAlerts = False 
       wb.Worksheets("Merge Data").Delete 
       'wb.Worksheets("Audit").Delete 
       Application.DisplayAlerts = True 
      On Error GoTo HandleError 
      wb.Worksheets.Add After:=Worksheets(Worksheets.Count) 
      Set ws = ActiveSheet 
      ws.Name = "Merge Data" 

      'Insert Title Row and Format     NOTE: THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL. 
      '             I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT. 
      'ws.Cells(1, 1) = "Received" 
      ws.Cells(1, 1) = "Email Body" 
      ws.Cells(lngAuditRecord, 2) = "Subject" 
      'ws.Cells(lngAuditRecord, 4) = "Attachments Count" 
      'ws.Cells(lngAuditRecord, 4) = "Sender Name" 
      'ws.Cells(lngAuditRecord, 5) = "Sender Email" 
      ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select 
      Selection.EntireRow.Font.Bold = True 
      Selection.HorizontalAlignment = xlCenter 

      'Populate the workbook 
      For lngCount = 1 To lngTotalItems 
       Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems 
        i = 0 
        'read email info 
        While i < lngTotalItems 
         i = i + 1 
         If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i/lngTotalItems, "0%") & "..." 
         With objFolder.Items(i) 
          'Cells(i + 1, 1).Formula = .ReceivedTime 
          Cells(i + 1, 1).Formula = .Body 
          Cells(i + 1, 2).Formula = .Subject 
          'Cells(i + 1, 4).Formula = .Attachments.Count 
          'Cells(i + 1, 5).Formula = .SenderName 
          'Cells(i + 1, 6).Formula = .SenderEmailAddress 
         End With 
        Wend 
        'Set objFolder = Nothing 
       ws.Activate 
      Next lngCount 
      lngTotalRecords = lngCount 

      'Format Worksheet 
       Columns("A:A").Select 
       Selection.ColumnWidth = 255 
       Cells.Select 
       Selection.Columns.AutoFit 
       Selection.Rows.AutoFit 
       With Selection 
        .VerticalAlignment = xlTop 
       End With 
       Range("A1").Select 
     End If 
    ' 
    ' Check that records have been found: 
     If lngTotalRecords = 0 Then 
      MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found" 
      gblStopProcessing = True 
      GoTo HandleExit 
     End If 
    ' 
     With Selection 
      Cells.Select 
      .VerticalAlignment = xlTop 
      .WrapText = True 
     End With 
     Range("A1").Select 
    ' 
HandleExit: 
     On Error Resume Next 
     Application.ScreenUpdating = True 
     Set objNSpace = Nothing 
     Set objFolder = Nothing 
     Set objOutlook = Nothing 
     Set ws = Nothing 
     Set wb = Nothing 
     If Not gblStopProcessing Then 
       MsgBox "Processing completed" & vbCrLf & vbCrLf & _ 
       "Please check results", vbOKOnly + vbInformation, "Information" 
     End If 
    'Call ParseBlockingSessionsEmailPartTwo 
     Exit Sub 
    ' 
HandleError: 
     MsgBox Err.Number & vbCrLf & Err.Description 
     gblStopProcessing = True 
     Resume HandleExit 
    End Sub 

Answer 1

'add two vars, 1) for the number you seek, and 2) position of "BT#" prefix 
Dim strBTNum as String, lngPos as Long 
'check to see if your body contains the BT# 
lngPos = Instr(1, .Body, "BT#") 
If lngPos > 0 Then 'you found your prefix at position lngPos 
    'so get the eight digit number 
    strBTNum = Mid(.Body, lngPos + 3, 8) 
Else 
    strBTNum = "NotFound" 
End If 
'now put strBTNum wherever you want, maybe ...? 
Cells(i + 1, 3).Formula = strBTNum