A complex problem-replacing repetitive numbers with blank

Are the dates always part of the column title and in the same format mm/dd/yy?
A macro can do this.

Try the following macro:

Public Sub test()
Dim C_ell As Range, C_ell2 As Range, R_start As Range
Dim D_ay As Integer, M_onth As Integer, Y_ear As Integer
For Each C_ell In Range("B1", Cells(1, Columns.Count).End(xlToLeft))
  If InStr(1, C_ell, "dead", vbTextCompare) Then
    D_ay = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) - 2, 2)
    M_onth = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) + 1, 2)
    Y_ear = Mid(C_ell, InStr(InStr(1, C_ell, "/", vbTextCompare) + 1, C_ell, "/", vbTextCompare) + 1, 2)
    d_ate = DateSerial(Y_ear, M_onth, D_ay)
    Set R_start = Columns(1).Find(d_ate)
    For Each C_ell2 In Range(Cells(R_start.Row, C_ell.Column), Cells(Rows.Count, C_ell.Column).End(xlUp))
      C_ell2 = ""
    Next
  End If
Next
End Sub

It will work on the active sheet.

It will works on any data set. Larger is not a problem.
To add the word "susp" in the condition, here is how to do it. This modified macro will prevent any bug if the words "dead" or "susp" are present in the name of a client while there is no date in the column title. The error will stop the macro.

Public Sub test()
Dim C_ell As Range, C_ell2 As Range, R_start As Range
Dim D_ay As Integer, M_onth As Integer, Y_ear As Integer
On Error GoTo E_nd
For Each C_ell In Range("B1", Cells(1, Columns.Count).End(xlToLeft))
  If InStr(1, C_ell, "dead", vbTextCompare) Or InStr(1, C_ell, "susp", vbTextCompare) Then
    D_ay = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) - 2, 2)
    M_onth = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) + 1, 2)
    Y_ear = Mid(C_ell, InStr(InStr(1, C_ell, "/", vbTextCompare) + 1, C_ell, "/", vbTextCompare) + 1, 2)
    d_ate = DateSerial(Y_ear, M_onth, D_ay)
    Set R_start = Columns(1).Find(d_ate)
    For Each C_ell2 In Range(Cells(R_start.Row, C_ell.Column), Cells(Rows.Count, C_ell.Column).End(xlUp))
      C_ell2 = ""
    Next
  End If
Next
E_nd:
End Sub

see private message

I realized there were missing dates in column A. I thought either all dates of years were present or that the dates in titles were dates present in column A.
I modifiied the macro to take this into account.
It leaves you to make sure there is a date when a company is marked DEAD or SUSP.
I also added 2 message box to tell you when the macro was completed normally and when it encounters an error with the company name causing the error.

Public Sub Blank_Dead()
Dim C_ell As Range, C_ell2 As Range, R_start As Range
Dim D_ay As Integer, M_onth As Integer, Y_ear As Integer
Application.ScreenUpdating = False
On Error GoTo E_nd
For Each C_ell In Range("B1", Cells(1, Columns.Count).End(xlToLeft))
  If InStr(1, C_ell, "dead", vbTextCompare) Or InStr(1, C_ell, "susp", vbTextCompare) Then
    D_ay = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) - 2, 2)
    M_onth = Mid(C_ell, InStr(1, C_ell, "/", vbTextCompare) + 1, 2)
    Y_ear = Mid(C_ell, InStr(InStr(1, C_ell, "/", vbTextCompare) + 1, C_ell, "/", vbTextCompare) + 1, 2)
    d_ate = DateSerial(Y_ear, M_onth, D_ay)
    Do While R_start Is Nothing
    Set R_start = Columns(1).Find(d_ate)
    d_ate = d_ate + 1
    Loop
    For Each C_ell2 In Range(Cells(R_start.Row, C_ell.Column), Cells(Rows.Count, C_ell.Column).End(xlUp))
      C_ell2 = ""
    Next
    Set R_start = Nothing
  End If
Next
MsgBox "Ended without error", vbOKOnly, "COMPLETTED"
Exit Sub
E_nd:
Application.ScreenUpdating = True
MsgBox "Stopped because an error occured with company " & C_ell, vbOKOnly, "ERROR"
End Sub

Hoping it is all right now.

This might be a little faster

Option Explicit
Sub abc()
 Dim aArr, i As Long, ii As Long
 Dim dDate As Date
 Dim sMsg As String
 With Worksheets("sheet1")
    aArr = .Range("a1").CurrentRegion.Value
    With CreateObject("vbscript.regexp")
        .Pattern = "[\d]+[\/-][\d]+[\/-][\d]+"
        For i = 2 To UBound(aArr, 2)
            If UCase(aArr(1, i)) Like "*DEAD*" Or _
                UCase(aArr(1, i)) Like "*SUSP*" Then
                If .test(aArr(1, i)) Then
                    If IsDate(.Execute(aArr(1, i))(0)) Then
                        dDate = .Execute(aArr(1, i))(0)
                        For ii = 3 To UBound(aArr)
                            If CDate(aArr(ii, 1)) >= dDate Then
                                aArr(ii, i) = Empty
                            End If
                        Next
                    Else
                        sMsg = Join(Array(Trim$(sMsg), aArr(1, i)), vbCr)
                    End If
                Else
                    sMsg = Join(Array(Trim$(sMsg), aArr(1, i)), vbCr)
                End If
            End If
        Next
    End With
    .Range("a1").Resize(UBound(aArr), UBound(aArr, 2)) = aArr
 End With
 If sMsg <> "" Then
    MsgBox "No date found for :" & sMsg
 End If
End Sub

Try this.
Must be faster

Option Explicit

Sub test()
    Dim rng As Range, r As Range, myDate As Date, x
    Set rng = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Pattern = ".*(?:dead|susp).* (\d{2})/(\d{2})/(\d{2}) .*"
        For Each r In rng.Rows(1).Cells
            If .test(r.Value) Then
                'myDate = CDate(.Replace(r.Value, "$3/$2/$1"))
                 myDate = CDate(.Replace(r.Value, "$1/$2/$3"))
                 ' adjust to your regional setting
                 ' my regional setting works well with the top line.
                x = Application.Match(CLng(myDate), rng.Columns(1), 1)
                If IsNumeric(x) Then
                    rng.Columns(r.Column).Cells(x) _
                    .Resize(rng.Rows.Count - x + 1).ClearContents
                End If
            End If
        Next
    End With
End Sub

Your missing on column G though!

Originally Posted by jindon Ignore this, if this one is talking about my code.

Still wrong, even after editing your code... Column G Date is 05/02/01 which is 2/5/01. Below code starts at 12/31/2004 missing 3 years?

Option Explicit

Sub test()
    Dim rng As Range, r As Range, myDate As Date, x
    Set rng = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Pattern = ".*(?:dead|susp).* (\d{2})/(\d{2})/(\d{2}) .*"
        For Each r In rng.Rows(1).Cells
            If .test(r.Value) Then
                myDate = CDate(.Replace(r.Value, "$3/$2/$1"))
                x = Application.Match(CLng(myDate), rng.Columns(1), 1)
                If IsNumeric(x) Then
                    rng.Columns(r.Column).Cells(x) _
                    .Resize(rng.Rows.Count - x + 1).ClearContents
                End If
            End If
        Next
    End With
End Sub

Hi nilem , Hi jindon,
I got issues with both your macro. ABC macro runs real fast but it does not recognize all dates the same. Ususally, dates under 2000 are well interpreted but those above are wrongly converted.
I was not able to run the other macro as it was not seing any company to process. It is about the pattern I think.

To pahari75, you have to make sure the dates in the company names are present in the column A, otherwise the macro loops for a long time. My macro takes longer to run but I'm pretty sure of the results.
Regards

Hi nilem , Hi jindon,
I got issues with both your macro. ABC macro runs real fast but it does not recognize all dates the same. Ususally, dates under 2000 are well interpreted but those above are wrongly converted.
I was not able to run the other macro as it was not seing any company to process. It is about the pattern I think.

To pahari75, you have to make sure the dates in company names are present in column A otherwise the macro loops for a long time.
My macro takes more time to run but I'm pretty sure you'll get good results.

Originally Posted by p24leclerc

ABC macro runs real fast but it does not recognize all dates the same. Ususally, dates under 2000 are well interpreted but those above are wrongly converted.

Does it not works correctly on the example workbook? If not can you upload an example of where its not working?

Hi Mike,
I ran your ABC macro on sample book1 supplied by pahari75 in post #1.
On column G, here is the company name "A C E LABORATORIES DEAD - 05/02/01 - TOT RETURN IND"
Your macro returned 2005-02-01 as date. See attached file.

About nilem macro, I had to make a small modification to the pattern as it was looking for a space after the date which is how dates appear in the sample workbook but in another file supplied by pahari75, dates are at the end of the company name so there was no space.Once modified, I must say its the fastest one and it is doing a perfect job.

Here jindon's macro modified to accept dates at the end of company name:

Sub test()
    Dim rng As Range, r As Range, myDate As Date, x
    Set rng = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Pattern = ".*(?:dead|susp).*(\d{2})/(\d{2})/(\d{2}).*"
        For Each r In rng.Rows(1).Cells
            If .test(r.Value) Then
                myDate = CDate(.Replace(r.Value, "$3/$2/$1"))
'                 myDate = CDate(.Replace(r.Value, "$1/$2/$3"))
                 ' adjust to your regional setting
                 ' my regional setting works well with the top line.
                x = Application.Match(CLng(myDate), rng.Columns(1), 1)
                If IsNumeric(x) Then
                    rng.Columns(r.Column).Cells(x) _
                    .Resize(rng.Rows.Count - x + 1).ClearContents
                End If
            End If
        Next
    End With
End Sub

I think it is the first time I see REGEXP used in response to a thread. I must say I don't look at them all.
Thanks to all of you for this demonstration of REGEXP.

Your macro returned 2005-02-01 as date

Glad you got it working. I agree Jindon code is much faster, but as far as the date on my cpu the date is 5/2/2001. So like Nilem said it must be a regional setting in excel.

This works works for me

myDate = CDate(.Replace(r.Value, "$1/$2/$3"))

this dosent

myDate = CDate(.Replace(r.Value, "$3/$2/$1"))

The forum is dedicated to sharing knowledge and information, not proving who is a better programmer. Please refrain from arguing when answering posts. If you have an issue with another poster, contact each other using Private Messages (PM).

I think it could be done within the same macro. If the company name has DEAD/SUSP and a date, it is processed as required but if there is no date then the macro will remove but 10 of the repetitive data at the end of this company column.

Here is how I did it:

here is jindon macro modified with jindon today's macro to takes care of coimpany with the words DEAD or SUSP but without date in their names.
I used the original jindon macro and added an ELSE statement to process company names without date in their name. I also added an IF statement to make sure this company have the word DEAD or SUSP in the name. If so, I used jindon today's macro to remove repeating numbers at the end of its column keeping about 10 repetitive data.

Public Sub jindon_mod()
    Dim rng As Range, r As Range, myDate As Date, x, y, X_R As Range
    Set rng = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        For Each r In rng.Rows(1).Cells
          .Pattern = ".*(?:dead|susp).*(\d{2})/(\d{2})/(\d{2}).*"
          If .test(r.Value) Then
            myDate = CDate(.Replace(r.Value, "$3/$2/$1"))
            'myDate = CDate(.Replace(r.Value, "$1/$2/$3"))
             ' adjust to your regional setting
             ' my regional setting works well with the top line.
            x = Application.Match(CLng(myDate), rng.Columns(1), 1)
            If IsNumeric(x) Then
                rng.Columns(r.Column).Cells(x) _
                .Resize(rng.Rows.Count - x + 1).ClearContents
            End If
          Else 'Check if DEAD or SUSP (we already know there is no date)
              .Pattern = "dead|susp"
              If .test(r.Value) Then
                With r.CurrentRegion
                  Set X_R = .Columns(r.Column).ColumnDifferences(.Columns(r.Column).Cells(.Rows.Count))
                  y = X_R.Cells(X_R.Count).Row
                  If y < .Rows.Count - 1 Then
                      .Columns(r.Column).Cells(y + 10).Resize(.Rows.Count - y).ClearContents
                      'here you can change the 10 with any number of data you want to keep
                  End If
                End With
              End If
            End If
        Next
    End With
End Sub

P.S.: jindon, I always learn a lot looking at your code.

You're right. No needs to test the same thing twice.