Sub OutlookToExcel()

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim Msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strPath = "C:UsersmeDocumentsAction ItemsWMV 856 load.xlsm"
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Test")

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strPath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(2)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set Msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Msg.Body
intColumnCounter = intColumnCounter + 1
Next itm

'Move items
'   Set Vars
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items

'    Set Items Reference
    Set Items = fld.Items

'   Loop through the Items
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items.Item(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
'           // Set SubFolder of Inbox
            Set SubFolder = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Done")
'           // Mark As Read
            Item.UnRead = False
'           // Move Mail Item to sub Folder
            Item.Move SubFolder
        End If
    Next lngCount



SplitTextColumn

MakeOneColumn

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

Sub SplitTextColumn()
'Takes all data out of one cell and splits it by line

    Dim i As Long
    Dim vA As Variant


    [A1].Select   '<~~~ sometimes on this line
    Range(Selection, Selection.End(xlDown)).Select
    For i = 1 To Selection.Rows.Count
    vA = Split(Selection.Resize(1).Offset(i - 1), vbLf)
    Selection.Offset(i - 1).Resize(1, UBound(vA) + 1).Offset(, 1) = vA '<~~~ sometimes on this line
    Next

    [A1].CurrentRegion.Offset(0, 1).Select
        Selection.Copy
        Sheets.Add After:=ActiveSheet
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True


    End Sub

    Sub MakeOneColumn()
  'Takes data and stacks it in a single column (A)

        Dim vaCells As Variant
        Dim vOutput() As Variant
        Dim i As Long, j As Long
        Dim lRow As Long

        If TypeName(Selection) = "Range" Then
            If Selection.Count > 1 Then
                If Selection.Count <= Selection.Parent.Rows.Count Then
                    vaCells = Selection.Value

                    ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)

                    For j = LBound(vaCells, 2) To UBound(vaCells, 2)
                        For i = LBound(vaCells, 1) To UBound(vaCells, 1)
                            If Len(vaCells(i, j)) > 0 Then
                                lRow = lRow + 1
                                vOutput(lRow, 1) = vaCells(i, j)
                            End If
                        Next i
                    Next j

                    Selection.ClearContents
                    Selection.Cells(1).Resize(lRow).Value = vOutput
                End If
            End If
        End If

        Dim c As Range
        Set rng = ActiveSheet.Range("A1:A5000")
        For dblCounter = rng.Cells.Count To 1 Step -1
            Set c = rng(dblCounter)
            If c.Value Like "*MEADWESTVACO SUMMARY 856*" Then
            c.EntireRow.Insert
        End If
        Next dblCounter

    Sheets("Data").[A1].CurrentRegion.Delete

    Sheets("Sheet2").Range("A1", Cells(Rows.Count, 1).End(xlUp)).Copy Destination:=Sheets("Data").Range("A1")

    Sheets("Data").Range("A1").EntireRow.Delete

    Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).FormulaR1C1 = "LAST LINE"

    Sheets("Sheet2").Delete

    End Sub


    Sub MoveToDataSheet()


    Sheets("Data").[A1].CurrentRegion.Delete

    Sheets("Sheet2").[A:A].Copy Destination:=Sheets("Data").Range("A1")

    End Sub