Sub ExtractData()
Application.ScreenUpdating = False
Dim Whole As String
Dim Qty() As String
Dim StrtPos As Long
Dim EndPos As Long
Dim lr As Long
Dim I As Long
With Raw
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For I = 8 To lr
Whole = .Cells(I, 1)
'Event name
StrtPos = InStr(Whole, "Sub total") + 2
EndPos = InStr(Whole, " <")
.Cells(I, 2) = Mid(Whole, StrtPos + 10, EndPos - StrtPos - 10)
.Cells(I, 2) = Replace(.Cells(I, 2), Chr(10), "")
Reg.Cells(I + 1, 1) = .Cells(I, 2)
'First Name
StrtPos = InStr(Whole, "First Name") + 1
EndPos = InStr(Whole, "Last") - 2
.Cells(I, 3) = Mid(Whole, StrtPos + 10, EndPos - StrtPos - 10)
Surname
StrtPos = InStr(Whole, "Last Name") + 1
EndPos = InStr(Whole, "Post") - 2
.Cells(I, 4) = Mid(Whole, StrtPos + 9, EndPos - StrtPos - 9)
'Postcode
StrtPos = InStr(Whole, "Post Code") + 1
EndPos = InStr(Whole, "Phone") - 2
.Cells(I, 5) = Mid(Whole, StrtPos + 9, EndPos - StrtPos - 9)
On Error Resume Next
'eMail
StrtPos = InStr(Whole, "Email") + 1
EndPos = StrtPos + 50
.Cells(I, 6) = Mid(Whole, StrtPos + 5, EndPos - StrtPos - 5)
.Cells(I, 6) = Left(.Cells(I, 6), InStr(.Cells(I, 6), Chr(9)) - 1)
On Error GoTo 0
'Phone
StrtPos = InStr(Whole, "Phone") + 1
EndPos = InStr(Whole, "Email") - 2
.Cells(I, 7) = Mid(Whole, StrtPos + 5, EndPos - StrtPos - 5)
'Qty
StrtPos = InStr(Whole, ">")
EndPos = InStr(Whole, "First") - 1
.Cells(I, 8) = Mid(Whole, StrtPos + 4, EndPos - StrtPos - 6)
.Cells(I, 8) = Replace(.Cells(I, 8), Chr(9), "")
Qty = Split(.Cells(I, 8))
.Cells(I, 8) = Qty(1)
Reg.Cells(I + 1, "G") = Qty(1)
Next
End With
End Sub
The table in access is linked to a folder in outlook and contains the body of the emails I want to extract the data from.