• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Export email to excel file

V

VBAmature31

New Member
Hi All,

I have a macro to export new emails directed to a specific folder,It works but it puts all the data in one cell,

Do any of you know how I get it to break out the data based on a carriage return,I need it broken out into columns.

See attached example file(Sheet 1 is raw data after script runs from out look and sheet 2 is how I want it to be) and also macro to get data into file.

It will be continuous and I need it to enter onto the the next free row as more emails come in.

Code:

Code: 
Option Explicit
Private Const xlUp As Long = -4162

Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
             
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets("Sheet1")

    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
    rCount = rCount + 1
   
    sText = olItem.Body

    Set Reg1 = CreateObject("VBScript.RegExp")
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric
   
    With Reg1
        .Pattern = "((P130\w*)\s*(\w*)\s*(\w*)\s*(\w*)\s*([\d-\.]*))"
    End With
    If Reg1.test(sText) Then
   
' each "(\w*)" and the "(\d)" are assigned a vText variable
        Set M1 = Reg1.Execute(sText)
        For Each M In M1
          vText = Trim(M.SubMatches(1))
          vText2 = Trim(M.SubMatches(2))
          vText3 = Trim(M.SubMatches(3))
          vText4 = Trim(M.SubMatches(4))
          vText5 = Trim(M.SubMatches(5))
        Next
    End If

  xlSheet.Range("B" & rCount) = vText
  xlSheet.Range("c" & rCount) = vText2
  xlSheet.Range("d" & rCount) = vText3
  xlSheet.Range("e" & rCount) = vText4
  xlSheet.Range("f" & rCount) = vText5

    xlWB.Close 1
    If bXStarted Then
        xlApp.Quit
    End If
    Set M = Nothing
    Set M1 = Nothing
    Set Reg1 = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Any help here would be greatly appreciated!
 

Attachments

  • sample.xlsx
    13.7 KB · Views: 8
Hi !

Better is to fix data directly from Outlook than after within Excel !

Anyway, a start you can mod to reach your final need :​
Code: 
Sub Macro1()
     Dim C&, K&, VA, SP$()
     Application.ScreenUpdating = False
     Cells(1).Replace vbCrLf, vbTab, xlPart
     Cells(1).TextToColumns Tab:=True
With ActiveSheet.UsedRange.Rows("1:2")
    VA = .Rows(1).Value
    ReDim VR$(1 To 2, 1 To UBound(VA, 2))
For C = 1 To UBound(VA, 2)
              SP = Split(VA(1, C), ":")
    If UBound(SP) > -1 Then
        K = K + 1:             VR(1, K) = SP(0)
        If UBound(SP) > 0 Then VR(2, K) = LTrim(SP(1))
    End If
Next
    .Value = VR
    .Columns.AutoFit
End With
     Application.ScreenUpdating = True
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
 
Hi Marc,

Thanks for your response,do I put this code in with my original code in outlook or create a new code in the "Sample file"?

sorry i'm not quite sure where to put the code.

Thanks
KD
 

I just try within Excel workbook as stand alone …

Paste it to the worksheet module.
​
 
Hi Marc,

Thanks got it to work,

sorry to keep annoying you,is there anyway if I have more than one cell to break out,is there a way of doing all the cells containing data?

Thanks
KD
 

It seems you don't Like my code post …

So I'm blind without an attachment according to your last post !
​
 
Hi Mark,
Sorry your code works and I do like it!....apologies my last post makes sense what I mentioned to say was:
I was wondering if I have several cells containing the raw data on sheet1. Is there a loop I could use to do to each of them what your code above does?
Thanks
KD
 

Yes with a loop to break data row by row …

It depends on source data and the expected layout result,
so without any sample, I'm still blind …
​
 
Hi Marc,

Sorry find attached the sample file,data source will always be in the same format as in sheet one and expected layout is as is on sheet2.

Let me know if this is enough.

thanks for your help so far its much appreciated.

Thanks
KD
 

Attachments

  • sample.xlsm
    21.4 KB · Views: 12
Hi Marc,

Sorry it came from Sheet1 A3,I cut it into the row 3.
The data will all be going into Column A and to the first available cell.

Thanks
Keith
 
According to your last attachment :​
Code: 
Sub Macro2()
     Dim C&, K&, R&, S$, SP$(), VA
     Application.ScreenUpdating = False
     Sheet3.UsedRange.Offset(1).Clear
With Sheet1.Cells(1).CurrentRegion.Rows
     S = "2:" & .Count
    .Item(S).Columns(1).Copy Sheet3.[A2]
End With
With Sheet3.UsedRange.Rows(S).Columns(1)
    .Replace Chr(160), " ", xlPart
    .Replace vbCrLf, vbTab, xlPart
    .TextToColumns Tab:=True
End With
With Sheet3.UsedRange.Rows(S)
    VA = .Value
    ReDim VT$(1 To UBound(VA), 1 To UBound(VA, 2))
For R = 1 To UBound(VA)
        K = 0
    For C = 1 To UBound(VA, 2)
       SP = Split(LTrim(VA(R, C)), ":")
        K = K - (UBound(SP) > -1)
        If UBound(SP) > 0 Then VT(R, K) = LTrim$(SP(1))
    Next
Next
    .Value = VT
     Application.Goto .Cells(1)(0), True
End With
     Application.ScreenUpdating = True
End Sub
You may Like it ! So thanks to click on bottom right Like …
​
 
I saw your question from conversation by e-mail but I can't reach it
anymore, so no more question by conversation …

As you may see within the code, carriage returns are converted to tab
to break lines in columns. And colon ":" is the character
to separate data from title within each column …

My code is a pity for this kind of stuff as it is far smarter to directly
proper work from source data and not after a mixing under Excel.
It works according to your last attachment and may not give expected
result for another workbook with a different data layout …
​
 
You must log in or register to reply here.
Back
Top