copy Outlook Body and paste match Destination Formatting to excel cell

[hajiali]

Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim iRow As Long
Dim sFilterStart As String
Dim sExtract As String
Dim aExtract() As String
Dim MT As Long
Dim Mnth As String

Set olApp = GetOL()
Set olNS = GetNS(olApp)

On Error Resume Next
MT = InputBox("WHAT MONTH BID DO YOU WANT TO IMPORT? TYPE THE MONTH NUMBER 1-JANUARY..ETC")
Mnth = MonthName(MT)
If MT = 0 Then
Exit Sub
Else
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("Bids").Folders(Mnth)

iRow = Range("Y" & Rows.Count).End(xlUp).Row + 1


For Each olMail In olFolder.Items
aExtract() = Split(olMail.Body, sFilterStart, 1)
ActiveSheet.Cells(iRow, "Y").Value = aExtract
iRow = iRow + 1
Next olMail
End If
End Sub
Function GetOL() As Outlook.Application
On Error Resume Next
Set GetOL = GetObject(, "Outlook.Application")
If GetOL Is Nothing Then
Set GetOL = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function
Function GetNS(olAppTemp As Outlook.Application) As Outlook.Namespace
Set GetNS = olAppTemp.GetNamespace("MAPI")
End Function

using a code form web I was able to modify the code copies each email body in specific folder of outlook and pastes it in column Y of the sheet.

Im needing this changed a little: here is what i need instead

step 1) I want to be able to copy everything in outlook body from "NAME:" to the end of the body and paste match Destination Formatting it to my excel activesheets.range("Y5"). (the pasting match destination formatting will cover Range("Y5:AH73"))
step 2) then copy range("AK1:AK400") and paste it transpose to anther sheet. (I have these range pull certain values from range("Y5:AH73")
step 3) then range("Y5:AH73").ClearContents
step 4) get next email and start step 1 - 3 over

Iv been trying to get this for the past few weeks any help is greatly appreciated. let me know if you need me to clarify anything.

Thanks

 

[hajiali]

Sub EmailCopy()
Dim NextRow As Range
Set NextRow = Sheets("Bid Data").Range("D" & Sheets("Bid Data").Range("D" & Rows.Count).End(xlUp).Row + 1)
    Sheets("Form").Range("AK1").Copy
    NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
    Set NextRow = Sheets("Bid Data").Range("E" & Sheets("Bid Data").Range("E" & Rows.Count).End(xlUp).Row + 1)
    Sheets("Form").Range("AK2:AK600").Copy
    NextRow.PasteSpecial Paste:=xlValues, Transpose:=True
    Application.CutCopyMode = False
End Sub

I was able to make Step 2 code so all I would have to do is Call EmailCopy if anyone can help me with step 1 and 4 to loop to next email I believe i can get the others done.