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

jfarc

Active Member
Joined
Mar 30, 2007
Messages
316
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:

Code:
  ~ 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:
Code:
*** 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:
Code:
  ~ 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.
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
This is going about it the hard way but try this in a new workbook and see if it will do what you need.
Code:
Sub tilde()


    Dim NuText As String
    Dim OlText As String
    Dim i As Long
    Dim k As Long


    OlText = Range("A1")
    
    For i = 1 To Len(OlText)
        If Mid(OlText, i, 3) = "***" Then
            If IsNumeric(Mid(OlText, i + 4, 2)) = True Then
                If IsNumeric(Mid(OlText, i + 7, 2)) = True Then
                    If IsNumeric(Mid(OlText, i + 10, 2)) = True Then
                        If NuText = "" Then
                            NuText = Left(OlText, i - 1) & "~"
                            Range("B1") = NuText
                            k = i + 3
                            i = i + 2
                        ElseIf NuText <> "" Then
                            NuText = NuText & Mid(OlText, k, i - k) & "~"
                            Range("B1") = NuText
                            k = i + 3
                            i = i + 2
                        End If
                    
                    End If
                End If
            End If
        End If
    Next i


    Range("B1") = NuText


End Sub

I am sure there is a much better way to do this but I don't know it!
 
Upvote 0
a single tilde followed by a space followed by the same time followed by a space

I want to replace the following 3asterisks and time and a space with 3spaces, tilde and the same time and a space:
I may have a very simple macro solution for you depending on your answers to the following two questions...

1) The above to lines are from your message and seem to contradict each other. Do you want "no spaces in front of the tilde" or "three spaces in front of the tilde" for the part that replaces the three asterisks (which would then be followed by a space and the date)?

2) Am I correct in assuming there is always only ONE space between the three asterisks and the date whereas the are always TWO or more spaces (as your example shows) between the three asterisks and a non-date?
 
Upvote 0
I may have a very simple macro solution for you depending on your answers to the following two questions...

1) The above to lines are from your message and seem to contradict each other. Do you want "no spaces in front of the tilde" or "three spaces in front of the tilde" for the part that replaces the three asterisks (which would then be followed by a space and the date)?

2) Am I correct in assuming there is always only ONE space between the three asterisks and the date whereas the are always TWO or more spaces (as your example shows) between the three asterisks and a non-date?

Answer 1) three spaces in front of the tilde

Answer 2) Yes it seems always only one space in between 3asterisks and time. But, can't commit to always 2 or more spaces between non-date asterisks.
 
Upvote 0
Answer 1) three spaces in front of the tilde
Just verifying... you want to replace three characters (the three asterisks) with four characters (three spaces and a tilde) and that is to then be followed by the existing space and date, correct


But, can't commit to always 2 or more spaces between non-date asterisks.
That is too bad... if you had been able to confirm that, I could have given you a very fast, two line macro, but if a non-date is able to have only one space between it and the three asterisks, the approach I wanted to use won't work and slower code will be needed. I'll see if I can improve on the code MPW posted and post back here if I can.
 
Upvote 0
Just verifying... you want to replace three characters (the three asterisks) with four characters (three spaces and a tilde) and that is to then be followed by the existing space and date, correct

That is correct (it's really the time though HH:MM:DD) I know the date follows it, but don't need to include it.

That is too bad... if you had been able to confirm that, I could have given you a very fast, two line macro, but if a non-date is able to have only one space between it and the three asterisks, the approach I wanted to use won't work and slower code will be needed. I'll see if I can improve on the code MPW posted and post back here if I can.


Yes, this routine has been in place for about a year now and (for the most part) was working fine with the below code:
Code:
    Selection.Replace What:="   ~*~*~* ", Replacement:="   ~ ", LookAt:=xlPart

But then we started noticing on occasion give erroneous results because the 3asterisks were at times not lead with 3spaces thus confusing them with the other 3asterisks. The only thing consistant with the other 3asterisks are they are not followed by the time format. Although, I have not found an instance of the 3asterisks1spacetimeformat not being the exact pattern I want to replace.

I've been out on road today and haven't tried MPW solution. I'm typically working with 3-4k records. Time isn't extremely critical. Can take a minute or so of process time if need be.
 
Last edited:
Upvote 0
Sorry about that I missed the 3 spaces that you wanted. It is an easy change.

How many cells is this to be run on?
 
Upvote 0
... this routine has been in place for about a year now and (for the most part) was working fine with the below code:
Rich (BB code):
    Selection.Replace What:="   ~*~*~* ", Replacement:="   ~ ", LookAt:=xlPart
But then we started noticing on occasion give erroneous results because the 3asterisks were at times not lead with 3spaces thus confusing them with the other 3asterisks. The only thing consistant with the other 3asterisks are they are not followed by the time format. Although, I have not found an instance of the 3asterisks1spacetimeformat not being the exact pattern I want to replace.
Hope this will suit:
Rich (BB code):
' Select cells to be replaced and run this macro
Sub Main()
  Dim a, r&
  With Selection
    a = .Value
    If Not IsArray(a) Then ReDim a(1 To 1, 1 To 1): a(1, 1) = .Value
    For r = 1 To UBound(a)
      If Len(a(r, 1)) Then a(r, 1) = MyReplace(a(r, 1))
    Next
    .Value = a
  End With
End Sub
 
Function MyReplace(ByVal Txt As String) As String
  Const s$ = vbTab & vbTab & vbTab
  Dim i As Long
  i = InStr(1, Txt, "*** ", vbBinaryCompare)
  While i
    If Mid$(Txt, i + 4, 8) Like "##:##:##" Then
      Mid$(Txt, i) = s
      i = i + 11
    End If
    i = InStr(i + 1, Txt, "*** ", vbBinaryCompare)
  Wend
  MyReplace = Replace$(Txt, s, "~")
End Function
You may change Replace$(Txt, s, "~") by Replace$(Txt, s, String(3," ") & "~") if required
 
Last edited:
Upvote 0
The same as previous but with some improvements:
1. It works in all columns of the selection instead of the 1-st column only.
2. Code loops only selected cells of the used range regardless full columns/rows are selected
Rich (BB code):
' Select cells to be replaced and run this macro
Sub Main()
  Dim a, c&, cc&, r&
  On Error Resume Next
  With Intersect(Selection, Selection.Worksheet.UsedRange)
    a = .Value
    If Not IsArray(a) Then ReDim a(1 To 1, 1 To 1): a(1, 1) = .Value
    cc = UBound(a, 2)
    For r = 1 To UBound(a)
      For c = 1 To cc
        If Len(a(r, c)) Then a(r, c) = MyReplace(a(r, c))
      Next
    Next
    .Value = a
  End With
End Sub
 
Function MyReplace(ByVal Txt As String) As String
  Const s$ = vbTab & vbTab & vbTab
  Dim i As Long
  i = InStr(1, Txt, "*** ", vbBinaryCompare)
  While i
    If Mid$(Txt, i + 4, 8) Like "##:##:##" Then
      Mid$(Txt, i) = s
      i = i + 11
    End If
    i = InStr(i + 1, Txt, "*** ", vbBinaryCompare)
  Wend
  MyReplace = Replace$(Txt, s, "~") ' or = Replace$(Txt, s, "   ~")
End Function

Result of the time test: approx 2 sec per 10000 cells
 
Last edited:
Upvote 0
Using your requested Column A for the data, here is what I came up with...
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top