Remove string in the cell

[hong224]

Dear Expertise,

I write the VBA code to import the email content from outlook to excel , but there are some character to remove and export to csv format.

There are different character in the one cell

E.g. I export the email content to excel in on cell

#############Before#######################
D7 cell contain original email content as below

Dear Support Team,

Please confirm the change will be carried out the below schedule

Time is 7:00 pm and SIC should be take caution on the change

Please inform to end users to stop the application and logoff

Time completed will be 10:00 pm

I want to write the VBA code

###############After VBA ####################

Please confirm the change will be carried out the below schedule
Time is 7:00 pm and SIC should be take caution on the change
Please inform to end users to stop the application and logoff

I have no idea how to write the vba to get this result .

Please help me the hints to do so

 

[JGordon11]

The codes below should work on your example. TrimTextD7 works specifically on cell D7 in the active sheet. TrimTextActiveCell works on whatever cell is selected in the active sheet. Both do nothing if the text is not delimited by double line feeds. If the text is delimited by double line feeds and there are three or more lines of text, then the first and last lines are deleted and line spacing reduced to single.

Sub TrimTextD7()
    Dim t, i As Long, output As String, ubt As Long
    t = Split(Range("D7"), Chr(10) & Chr(10))
    ubt = UBound(t)
    If ubt < 2 Then Exit Sub
    For i = 1 To ubt - 1
        output = output & t(i) & Chr(10)
    Next
    Range("D7") = Left(output, Len(output) - 1)
End Sub

Sub TrimTextActiveCell()
    Dim t, i As Long, output As String, ubt As Long
    t = Split(ActiveCell, Chr(10) & Chr(10))
    ubt = UBound(t)
    If ubt < 2 Then Exit Sub
    For i = 1 To ubt - 1
        output = output & t(i) & Chr(10)
    Next
    ActiveCell = Left(output, Len(output) - 1)
End Sub