Need to delete multiple lines in cells but keep one

Need a Macro that does the following:

For cells with multiple lines in a range
1. Deletes all dates/text that are striked out
2. Keeps only the remaining date/text that is next-in-line whether it be black and not striked out, colored, or italicized
3. Deletes the other dates/text following that kept date/text
4. Changes the color of the kept date/text to black (if it was red or a different color)
5. Does not change the dates/text font format whether it be italicized or not
6. Does not change the cells fill color

Examples: the following are lists in individual cells. ALSO SEE ATTACHMENT for sample file
---------------------------
08/01/12 *underlines indicate strikethrough
06/01/13
12/31/12
05/31/13
06/30/13
06/30/13
-----------------------------
06/30/12
01/31/13
03/07/13
06/05/13
-----------------------------
06/08/11
12/09/11
-----------------------------
09/22/11
10/31/12
03/06/12
-----------------------------
09/01/10
01/01/12
N/A
Design-Build
---------------------------------

After running the macro, the result should look like this for each individual cell based on the previous examples
-----------------------------
06/01/13
----------------------------
06/05/13
---------------------------
06/08/11
---------------------------
03/06/12
---------------------------
N/A
---------------------------

Any helpful comments or suggestions are welcome. Thank you for the help in advance.
Javier20h

I have added the desired results into the file. Thank you for the suggestion.

Thank you for your reply. I tried running the code but I get an error message at the line "MyText = MyText & .Text" saying, < unable to get the text property of character class >. Also, does this macro run for the entire sheet or a selected range? Thanks again for the help

I got it to work on that file. I was testing it on another file that I will post. This is the file im working on excluding unneeded info. I found that the problem is the "project no" column. If there is a number in there, the macro won't run. after I deleted the project numbers, it ran.

Also, I noticed that the cells that have a strikethrough date(s) followed by a red date, the red dates are being deleted but they are not supposed to be. The red date need to be kept and changed to black if possible.

And I'm not sure if its possible but is there a way to shift the values up (by delete the empty lines above) to the first line in the cell after deleting the dates before.

Thank you for the help. Its almost perfect.

It looks like some strikethrough dates are kept as well after running the macro.

Yes, the range should always be the same. Now I just need to fix the following minor problems:
1. The cells that have a strikethrough date(s) followed by a red date, the red dates are being deleted but they are not supposed to be. The red date need to be kept (and changed to black if possible).
2. Is there a way to shift the values up (by delete the empty lines above) to the first line in the cell after deleting the dates before?
3. Some strikethrough dates are kept after running the macro.

Thanks

Amazing, it works almost exactly right. There is only one problem.

1. The red dates and italic dates after strikethrough dates are being deleted. See rows 21,22,23,25,51 column o (format?),61,62,64,and others -- AFTER RUNNING THE MACRO

I posted the updated file with the improved macro. I included in the file the desired results and the original info.

The last thing to fix is to keep the red and italic dates that follow strikthough dates or that are the first line in the cell.

Thanks for all the help. Almost Solved!

This is what I was trying to say: If there is a strikethrough date followed by an italic or/and a red colored date, that date is deleted and the cell is blank. There should be a date that remains. If you run the code, you will see blanks where this situation occurs. There should be at least one line of information in every cell. Compare the desired to the tested after running the macro (in the most resent uploaded file). I will try to rearrange the code to fit my goal but if you or anyone can figure it out before I do that would be very helpful.

Thank you again.

Good suggestion! I will post a file shortly

Nice! That fixed the Red font problem. One last problem:
1. Italic dates are not being kept. (Again, this may be formatting problem)

Im posting another sample file that shows this problem. After this, then all my problems will be solved.
Thanks for the continuing help.

That almost worked. There are some cases where Italic font should be deleted such as after a date that is saved because it was not striked through. However, if there is an italic date first in the first line of a cell (or after some strikethrough dates), it should be kept and the dates following should be deleted.

In other words not all italics should be kept or deleted. Should be deleted if it follows a non strikethrough date. Should not be deleted if it is the first date after strikethroughs or first date in the cell. I think there needs to be a condition that evaluates these situations in the code.

Another idea, If we can delete all font that is in the second line of a cell (not in the first line), after running the bbtest4 code, that should solve the problem. Just an idea

I stumbled across this code that creates a pop-up window and allows you to keep the first X amount of characters and select a range. I kept the first 9 characters and that seemed to work well for my problem. There should be a way to change the code to eliminate the pop-up menu and change the code to always keep the first 9 characters for our range. Im sure if there is a way to include this code at the end of the existing one so that it will run one code after another.

Sub leftXChrs()
'keeps left x characters of a selected range
Dim c As Range
Dim mychrs As Long
On Error Resume Next
    mychrs = InputBox("Be sure to select a range of cells. " _
    & Chr(13) & "How many characters to keep?", 1)
        If mychrs = False Or Not Application.IsNumber(mychrs) Then
        Exit Sub
        End If
    For Each c In Selection
    c.Value = Left(c.Value, mychrs)
    Next c
End Sub

It works really good. I have two small problems.
1. is that some of the Italic Dates get changes to regular (because of the format of the lines above, I believe). I havent been able to figure out why they change to non-italic or a way to keep them italic. I need to check the formatting of the cell

2. all the font colors dont get changed to black in the end

Here are the current codes I am using to Solve this problem.

Sub bbtest4()
Dim cell As Range
numrow = ActiveSheet.UsedRange.Rows.Count
Set Rng = ActiveSheet.Range("O7:S" & numrow)
For Each cell In Rng
  If Not IsDate(cell.Value) Then
    For i = 1 To Len(cell.Text)
        With cell.Characters(i, 1)
            If .Font.Bold Or .Font.Strikethrough _
            Or .Font.Superscript Or .Font.Subscript Or .Font.OutlineFont _
            Or .Font.Shadow Or (.Font.Color > 1 And .Font.Color <> 255) Then
            Else
                MyText = MyText & .Text
            End If
        End With
    Next i
    cell.Value = MyText
    cell.Font.ColorIndex = 1
    cell.Font.Strikethrough = False
    Do While Left(cell.Text, 1) = vbLf
      cell.Value = Right(cell.Text, Len(cell.Text) - 1)
    Loop
    cell.Value = Left(cell.Text, 9)
    MyText = ""
  End If
  
Next
End Sub

and

Sub Black()
    Range("O7:S7").Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Range("O7").Select
End Sub

almost, I need to merge the codes or change the bbtest4 so that it changes the all the text in the range to black at the end.

is there a way to run two codes under one macro? or merge these codes into one.

another problem: running the code on an earlier sample file deletes some wording in cells that i want to keep. I'll post a new sample file showing this. My thought for a solution:

1. Run the code without keeping the first 9 characters
2. Then, delete everything after the first line in a cell EXCEPT words/lettering/phrases such as "N/A" or "Design-Build"

There may be a better way to do this. That is just my thought process.

And the italic problem is still an issue. When the dates get shifted up they change from italic to normal. Also, some dates get mashed together after running the code. Dont know what is doing that either. I'll investigate further.

Im getting a run-time error at the line ".ColorIndex = xlAutomatic". Everything seems right. What could be the problem?

Here is the updated samplefile with bbtest6.

fixed it...

 
.
.  
   
.Font.ColorIndex = xlAutomatic
.Font.TintAndShade = 0

.
.

Works great! Really good... one small small problem. One cell in the entire file isnt resolving. Here is the samplefile with problem. The yellow highlighted cells. I thought the code was going to keep the first line which is "N/A" and search to keep "Design-Build", but after running the code, its keeping the first 9 characters which are "N/A" and "Desig" as you will see, then searches for "N/A" and "Design-Build" which doesnt exist after keeping the 9.

That code did't work. It made things worse by copying and replacing with "N/A" and "Design-Build" into the cells that follow.

This is the round about way how I fixed this. I kept bbtest6, then I recorded a macro that replaces "Desig" with "Design-Build" but then another problem happens because the other Design-Builds get altered to "Design-Buildn-Build" so then I replace Design-Buildn-Build with "Design-Build". This is a random way to fix this problem. Here is the code:
Should we add this into the main code or find another solution?

Sub ReplaceDesign()
' ReplaceDesign Macro
'
    Cells.Find(What:="N/A" & Chr(10) & "Desig", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Cells.Find(What:="N/A" & Chr(10) & "Desig", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Cells.Replace What:="N/A" & Chr(10) & "Desig", Replacement:="N/A" & Chr(10) & "Design-Build", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="N/ADesign-Buildn-Build", Replacement:= _
        "N/A" & Chr(10) & "Design-Build", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
        False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Find(What:="N/A" & Chr(10) & "Design-Buildn-Build", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Cells.Replace What:="N/A" & Chr(10) & "Design-Buildn-Build", Replacement:= _
        "N/A" & Chr(10) & "Design-Build", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
        False, SearchFormat:=False, ReplaceFormat:=False
End Sub

or exclude cells that contain the words "Contruction Completed"

Is there a way to change the recorded macro to only effect the same range.

Also, I need to change the code to exclude any cells with the color RBG (247, 151, 70) from bbtest6. these cells have a long string of letters that i need to save. The current code keeps the first 9 characters which deletes a lot of the content in those cells.

I ran the code but for some reason, the cells that contain the words "Construction Completed" still get edited by the 9 characters line. I think it has to do with the order in the code. Probably have to rearrange the code. Something like:
1. Move "If InStr(cell.Text, "Contruction Completed") = 0 Then" down before "...cell.text, 9"
2. add a condition such as... if the cell contains "Contruction Completed ...", then skip cell
3. If the cell doesnt have that then edit cell to 9 characters.

there was a typo... "Construction Completed". the Code worked great! I think it is solved. thanks for all the help. I may post more simple question in the future. I hope you will help again. Thank you.