VBA Pattern matching with replacement of only a portion of pattern found

[jfarc]

The goal is to replace all the occurrences of "*** HH:MM:SS " - (3 asterisks followed by a space followed by the time hrs:mins:secs followed by a space) with " ~ HH:MM:SS " (a single tilde followed by a space followed by the same time followed by a space)

The problem is there are also multiple occurrences of the 3asterisks without the time following it that I do not want to replace.

This is an example of data in a single cell:

  ~ 17:35:28  15 AUG   JENNIFER_HALL ***   ||LIEN-RL| |RESOLVD|    *** 09:11:33  14 AUG   DEALEREXAM ***   ||LIEN-RL| Aug07-(Esta) CUST ORDERED LIEN RELEASE    *** 09:11:23  14 AUG   DEALEREXAM ***   ||IM-FORM| Jul25-(Hall) NEED I.O.A FORM*** 09:11:19  14 AUG   DEALEREXAM ***   ||LIEN-RL| Jul25-(Hall) NEED L/R (PEOPLE'S FIRST LLC) -NO PAYOFF-MD TITLE    IN DEAL-F*I MJ   *** 16:02:20  31 JUL   JUDY,_MARILYN ***   BANK IS MAILING CUSTOMER LIEN RELEASE, WILL TAKE 7 TO 10 DAYS TO RECEIVE,    CUSTOMER WILL BRING IT IN AS SOON AS HE RECEIVES IT. MJJ   *** 09:47:32  22 JUL2014 lindsay JC-FI ESTABROOK,_LINDSAY ***   $49821.78 H/C 7/30   *** 17:36:07  21 JUL   JUDY,_MARILYN ***SENT TO ACCT ON 7/21/14

So, in the above single cell, I want to replace the following 3asterisks and time and a space with 3spaces, tilde and the same time and a space:

*** 09:11:33 
*** 09:11:23 
*** 09:11:19 
*** 16:02:20 
*** 09:47:32 
*** 17:36:07 
Replace above with:
~ 09:11:33 
~ 09:11:23 
~ 09:11:19 
~ 16:02:20 
~ 09:47:32 
~ 17:36:07

There are (6) other occurrences in this example cell of the 3asterisks that I do not want to replace.

This is what the above single cell would look like after the replacement happens:

  ~ 17:35:28  15 AUG   JENNIFER_HALL ***   ||LIEN-RL| |RESOLVD|    ~ 09:11:33  14 AUG   DEALEREXAM ***   ||LIEN-RL| Aug07-(Esta) CUST ORDERED LIEN RELEASE    ~ 09:11:23  14 AUG   DEALEREXAM ***   ||IM-FORM| Jul25-(Hall) NEED I.O.A FORM~ 09:11:19  14 AUG   DEALEREXAM ***   ||LIEN-RL| Jul25-(Hall) NEED L/R (PEOPLE'S FIRST LLC) -NO PAYOFF-MD TITLE    IN DEAL-F*I MJ    ~ 16:02:20  31 JUL   JUDY,_MARILYN ***   BANK IS MAILING CUSTOMER LIEN RELEASE, WILL TAKE 7 TO 10 DAYS TO RECEIVE,    CUSTOMER WILL BRING IT IN AS SOON AS HE RECEIVES IT. MJJ    ~ 09:47:32  22 JUL2014 lindsay JC-FI ESTABROOK,_LINDSAY ***   $49821.78 H/C 7/30    ~ 17:36:07  21 JUL   JUDY,_MARILYN ***SENT TO ACCT ON 7/21/14

Solution needs to be in VBA rather than a cell formula. Assume the column of data is in col 'A'. My failed attempted solutions either replaces all asterisks or replaces the original time wiping it out.

 

[Rick Rothstein]

Using your requested Column A for the data, here is what I came up with...

Sub ThreeAsterisks()
  Dim R As Long, X As Long, Data As Variant, Asterisks() As String
  Data = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For R = 1 To UBound(Data)
    Asterisks = Split(Data(R, 1), "***")
    For X = 1 To UBound(Asterisks)
      If IsDate(Split(Asterisks(X))(1)) Then Asterisks(X) = Chr(1) & Asterisks(X)
    Next
    Data(R, 1) = Replace(Join(Asterisks, "***"), "***" & Chr(1), "   ~")
  Next
  Range("A1", Cells(Rows.Count, "A").End(xlUp)) = Data
End Sub

Use ZVI's code in Message #9 instead of the code I posted above... it's much faster. I get his code processing 10000 cells in 0.14 seconds whereas my code took 0.5 seconds.

 

[jfarc]

ZVI & Rick, I used both of your solutions from post #9&10 and they work very nicely on several days worth of live data. I will put one into production tomorrow and key an eye on it.

Thank you!

 

[jfarc]

Use ZVI's code in Message #9 instead of the code I posted above... it's much faster. I get his code processing 10000 cells in 0.14 seconds whereas my code took 0.5 seconds.

Well maybe you just need to put a little more effort into it. Ha!

 

[Rick Rothstein]

Well maybe you just need to put a little more effort into it. Ha!

Okay, I did... the following is the same number of code lines as my previously posted sub (I tend to like compact code) and is only 0.03 second slower than ZVI's sub (0.17 seconds for 10,000 cells versus 0.14 seconds).

Sub ThreeAsterisks()
  Dim r As Long, X As Long, Data As Variant
  Data = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For r = 1 To UBound(Data)
    Do
      X = InStr(X + 1, Data(r, 1), "***")
      If Mid(Data(r, 1), X + 3, 9) Like " ##:##:##" Then Mid(Data(r, 1), X, 3) = "@@@"
    Loop While X > 0
    Data(r, 1) = Replace(Data(r, 1), "@@@", "   ~")
  Next
  Range("A1", Cells(Rows.Count, "A").End(xlUp)) = Data
End Sub

 

[jfarc]

(I tend to like compact code)

Well that's obvious! I get a kick out of accomplishing a task with the least amount of effort (of course, that takes into account the vast amount of expertise acquired over the years used to create the solution). I like it and understand it. I'm still chewing on ZVI's code to make sure I understand what each line is doing.

Thanks to the three of you for your efforts, this is exactly what I was looking for.

 

[MPW]

See, I kew there was a better way