Copy and Paste from email to excel Workbook reaching max for cell wont copy more 1

[vba317]

I am using Excel 2010 and Outlook 2010. What I am trying to do is copy the contents of an email into an excel spreadsheet. Currently I can pick the right email and I can copy and paste into the worksheet. The problem is the paste function is pasting into 1 cell instead of multiple cells. So I am not getting all the data because I have maxed out the contents of the cell. Is there a way of copying the contents one line at a time? Currently I am copying the whole email at once. Tom

Public Sub Dwnld_NetAdds()

Dim strDate1 As String
Dim strDate2 As String
Dim strDate3 As String
Dim strDateType1 As String
Dim strDateType2 As String
Dim strDateType3 As String
Dim strFile As String
Dim FolderTgt As MAPIFolder
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim strPath As String
Dim RowCrnt As Long
Dim TextBody As String
Dim xlApp As Excel.Application
Dim ObjOutlook As Object
Dim objFolder As MAPIFolder
Dim objMailbox As Object
Dim objNamespace As Namespace
Dim objInbox As Outlook.MAPIFolder
Dim strFolderName As String
Dim objItem As Object
Dim strRcvDate As String

Const olFolderInbox = 6

Set ObjOutlook = CreateObject("Outlook.Application")
Set objNamespace = ObjOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set FolderTgt = objMailbox.Folders("DailyNetAdds")

strPath = "\\cable\ncd-shared\DIV-FIN-Business-Analytics-Shared\Adhoc\Tom\DOR\Daily Net Adds\"
        strDateType1 = "C_M/D/YYYY"
        strDateType2 = "C_MMM YYYY"
       Call DefineDateType(strDate1, strDate2, strDate3, strDateType1, strDateType2, strDateType3)
strRcvDate = strDate1
   strFile = "NorthEast Daily Forecast - " & strDate2 & ".xlsm"
  ' Open copy of Excel
            Set xlApp = CreateObject("Excel.Application")
            Set xlBook1 = xlApp.Workbooks.Open(strPath & strFile)
            xlApp.Visible = True

  For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
    With FolderTgt.Items.Item(InxItemCrnt)
        If strRcvDate <> Date Then
                With Worksheets("Forecast")
                    RowCrnt = RowCrnt + 1
                    If TextBody <> "" Then
                    With .Cells(RowCrnt, "A")
                    ' The maximum size of a cell 32,767
                    .Value = Mid(TextBody, 1, 32700)
                    .WrapText = True
                End With
                    RowCrnt = RowCrnt + 1
                        TextBody = Replace(TextBody, Chr(160), "~")
                        TextBody = Replace(TextBody, vbCr, "~")
                        TextBody = Replace(TextBody, vbLf, "~")
                        TextBody = Replace(TextBody, vbTab, "~")
                        TextBody = Replace(TextBody, "~", "")
                    With .Cells(RowCrnt, "B")
                        ' The maximum size of a cell 32,767
                        .Value = Mid(TextBody, 2, 32700)
                        .WrapText = True
                    End With
                    RowCrnt = RowCrnt + 1
                End If
            End With
        End If
    End With
 Next
  Set xlApp = Nothing       ' Clear reference to Excel
End Sub

 

[SkipVought]

Hi,

The problem is that you are NOT using the Copy/Paste method!

You are assigning a value to a cell, plain & simple.

So I'd suggest using the Split function, with vbLf or vbCr as the delimiter, to put a paragraph at a time into the cells in your column.

 

[vba317]

I used your suggestion and it worked for my issue. I have copied the body of the email into an excel file. Now I need to extract the number from Column A and put the value into Column B. Currently what is happening is the text in Column A is being replaced with the value.

Tom

Dim ObjOutlook As Object
Dim objNamespace As Namespace
Dim objInbox As Outlook.MAPIFolder
Dim strFolderName As String
Dim objMailbox As Object
Dim objFolder As MAPIFolder
Dim objItem As Object
Dim File_Path As String
Dim Item As Outlook.MailItem
Dim Attachment As Object
Dim strFile As String
Dim strDate1 As String
Dim strDate2 As String
Dim strDate3 As String
Dim strDate4 As String
Dim strDateType1 As String
Dim strDateType2 As String
Dim strDateType3 As String
Dim strstrFile As String
Dim strOldName As String
Dim strNewName As String
Dim strOutputFile As String
Dim strRcvDate As Date
Dim strRcvDate1 As String
Dim strRcvDate2 As String
Dim intLoop As Integer
Dim intLoop1 As Integer
Dim strExt As String
Dim vlines As Variant
Dim lRow As Long
Dim i As Integer
Dim r As Range

Const olFolderInbox = 6

Set ObjOutlook = CreateObject("Outlook.Application")
Set objNamespace = ObjOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("DailyNetAdds")

strPath = "\\cable\ncd-shared\DIV-FIN-Business-Analytics-Shared\Adhoc\Tom\DOR\Daily Net Adds\"
        strDateType1 = "C_M/D/YYYY"
        strDateType2 = "C_MMM YYYY"
       Call DefineDateType(strDate1, strDate2, strDate3, strDateType1, strDateType2, strDateType3)
   strFile = "NorthEast Daily Forecast - " & strDate2 & ".xlsm"
  ' Open copy of Excel
            Set xlApp = CreateObject("Excel.Application")
            Set xlBook1 = xlApp.Workbooks.Open(strPath & strFile)
            xlApp.Visible = True
            'Today's Date
            strDate1 = Format(CDate(Date), "M/D/YYYY")
 For Each Item In objFolder.Items
    '''''Loop Thru Each Attachment
                strRcvDate = Format(CDate(Item.ReceivedTime), "M/DD/YYYY")
                If strRcvDate = strDate1 Then
                    lRow = 1
                        vlines = Split(Item.Body, vbCr)
                        For i = 0 To UBound(vlines)
                            ActiveSheet.Cells(lRow + i, 1).Value = vlines(i)
                            lRow = lRow + 1
                        Next
                 End If
    Next Item
    'Format NorthEast Daily Forcast file
    Rows("2:16").EntireRow.Delete
    Rows("3:13").EntireRow.Delete
    Rows("4:10").EntireRow.Delete
    Rows("5:7").EntireRow.Delete
    Rows("6:12").EntireRow.Delete
    Rows("7:17").EntireRow.Delete
    Rows("8:33").EntireRow.Delete
    
    'Loop Through A Column and copy values into B Column
    For Each r In Range("A2:A7")
        r.Value = Right(r.Value, 7)
    Next r
   
      
  ActiveWorkbook.SaveAs strPath & strFile & strExt
  Set xlApp = Nothing       ' Clear reference to Excel
End Sub

 

[SkipVought]

r.Offset(0,1).Value = Right(r.Value,7)

 

[vba317]

OK, That worked one final thing, Now that I have the numbers in Column B they have different amounts of white space in front of them. I have tried different methods but nothing I am trying is working.

   For Each r In Range("B2:B7")
       r.Value = Replace(r.Value, "", "")
    Next r

 

[SkipVought]

trin()?

 

[SkipVought]

Rather

Trim()

 

[SkipVought]

r.Offset(0,1).Value = Trim(Right(r.Value,7))

 

[vba317]

I didn't get any errors but it didn't work.
Column B is the number that was generated by the code, Column C is the results of using the LEN function. For some reason I am still getting characters.

Tom

B C
    669 7
(5,988) 5
  9,051 7
18,895 5
  5,710 7
 2,368 6

 

[SkipVought]

So what's in column A?

 

[vba317]

I just found out the data in the body of the email gets copied from the web. So I added another loop after your's and no more blank spaces. Column A is company sensitive but it is the text description and the number itself. Thanks so much for all your help.

Tom

    For Each r In Range("B2:B7").Cells
        r.Value = Replace(r.Value, Chr(160), "")
     Next r