Conditional replace accented characters with non-accented ones

I want to be able to correct a specific type of mistake in Greek (free) text. For any word that starts with an accented vowel or εύ, if there is anywhere in that word another instance of an accented vowel, then replace the first instance with the non-accented counterpart of that vowel. It should respect capitalization and replace with the capital counterpart in case it is capital.

(In the attached file, 3 sheets, 1 with vowel list, 2 with example replacements, 3 with free Greek text with words for correction).

For example

Find Replace
άγώνας αγώνας
άδελφός αδελφός
άερόστατο αερόστατο
άθέτησις αθέτησις
εύρέσεως ευρέσεως
εύρύτης ευρύτης
εύχέλαιο ευχέλαιο

Accented Non-Accented
ά α
έ ε
ή η
ΐ ι
ϊ ι
ί ι
ό ο
ύ υ
ΰ υ
ώ ω
εύ ευ

You've posted this in the Word Programming area of the forum.

Are you sure that's where it should be. The attachment is I believe an Excel file. Would you like me to move the post to an Excel area of the forum?

Hi Richard,

I want to run the macro in Word, I used Excel file as reference as it seemed better suited to structure the info.

I've answered a similar question before. See: http://www.excelforum.com/word-progr...ml#post3624829

Hi Paul,

This is a very different scenario in the sense that the point is not replacing a character with another one, but replacing a character on condition that another x character appears in the same word.

Thank you for your help in the other topic

I appreciate the differences, but the value ranges for the characters you'll be working with are the same and the code in that thread shows how you can go about specifying those characters and their replacements. One potential issue I can foresee is the need to handle hard & soft breathings on first or second characters that may or may not be accented in addition to those breathings. So perhaps you could clarify whether your text has hard & soft breathings.

Paul, the range of characters is almost entirely different; in the thread you refer to it is Greek extended (and I only posted a small subset of them there just for example's sake), in this case, it is Greek (Modern) and I have posted all the accented characters. The remaining, possible characters in-between the accented ones are Modern Greek, i.e. [α-ω] range.

http://en.wikibooks.org/wiki/Modern_Greek/Alphabet

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Range, i As Long, j As Long
StrFnd = "03AC 03B1 03AD 03B5 03AE 03B7 0390 03B9 03CA 03B9 03AF 03B9 03CC 03BF 03CD 03C5 03B0 03C5 03CE 03C9"
For i = 0 To UBound(Split(StrFnd, " ")) Step 2
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "<" & ChrW("&H" & Split(StrFnd, " ")(i)) & "*>"
      .Execute
    End With
    Do While .Find.Found = True
      Set Rng = .Duplicate
      With .Duplicate
        .Start = .Start + 1
        For j = 0 To UBound(Split(StrFnd, " ")) Step 2
          If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
            Rng.Characters.First.Text = ChrW("&H" & Split(StrFnd, " ")(i + 1))
            Exit For
          End If
        Next
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "<" & ChrW("&H03B5") & ChrW("&H03CD") & "*>"
    .Execute
  End With
  Do While .Find.Found = True
    Set Rng = .Duplicate
    Rng.Start = Rng.Start + 1
    With .Duplicate
      .Start = .Start + 2
      For j = 0 To UBound(Split(StrFnd, " ")) Step 2
        If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
          Rng.Characters.First.Text = ChrW("&H03C5")
          Exit For
        End If
      Next
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Wow, thanks, Paul!

Seems to work on all words except for ones starting with capital, i.e. Έλευσίνια should be made Ελευσίνια. Also, when I run it an exclamation message box appears with no other text and then the macro runs when I click OK.

Meanwhile I had gone as far as:
Find: <ά(*)([όέήύίΰϊώ]*>)
Replace: α\1\2

Could not figure out how to make the first character change so that it works for all characters needing replacement, i.e. define in the Replace operation the non accented character version of the character found, when there is a range of characters involved.

Regarding your Find/Replace approach, the problem is there is no way of defining the variable replacement. And, although one could specify the Find string as:
<[ΆΌΈΉΎΊΫΪΏάόέήύίΰϊώ]*[άόέήύίΰϊώ]*>
you can't simply encode the characters that way in VBA - you need to use the character codes as I have done - and you would still have the complication of using a loop to determine the replacement character. That approach might be slightly more efficient than the one I've taken and I might come back to that later.

In the meantime, the message box was just left over from testing and expanding the macro to handle capitals is easy enough:

Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Range, i As Long, j As Long
StrFnd = "03AC 03B1 03AD 03B5 03AE 03B7 0390 03B9 03CA 03B9 03AF 03B9 03CC 03BF 03CD 03C5 03B0 03C5 03CE 03C9"
For i = 0 To UBound(Split(StrFnd, " ")) Step 2
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "<" & ChrW("&H" & Split(StrFnd, " ")(i)) & "*>"
      .Execute
    End With
    Do While .Find.Found = True
      Set Rng = .Duplicate
      With .Duplicate
        .Start = .Start + 1
        For j = 0 To UBound(Split(StrFnd, " ")) Step 2
          If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
            Rng.Characters.First.Text = ChrW("&H" & Split(StrFnd, " ")(i + 1))
            Exit For
          End If
        Next
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "<" & UCase(ChrW("&H" & Split(StrFnd, " ")(i))) & "*>"
      .Execute
    End With
    Do While .Find.Found = True
      Set Rng = .Duplicate
      With .Duplicate
        .Start = .Start + 1
        For j = 0 To UBound(Split(StrFnd, " ")) Step 2
          If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
            Rng.Characters.First.Text = UCase(ChrW("&H" & Split(StrFnd, " ")(i + 1)))
            Exit For
          End If
        Next
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "<" & ChrW("&H03B5") & ChrW("&H03CD") & "*>"
    .Execute
  End With
  Do While .Find.Found = True
    Set Rng = .Duplicate
    With .Duplicate
      .Start = .Start + 2
      For j = 0 To UBound(Split(StrFnd, " ")) Step 2
        If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
          Rng.Characters.First.Next.Text = ChrW("&H03C5")
          Exit For
        End If
      Next
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "<" & UCase(ChrW("&H03B5")) & ChrW("&H03CD") & "*>"
    .Execute
  End With
  Do While .Find.Found = True
    Set Rng = .Duplicate
    With .Duplicate
      .Start = .Start + 2
      For j = 0 To UBound(Split(StrFnd, " ")) Step 2
        If InStr(.Text, ChrW("&H" & Split(StrFnd, " ")(j))) > 0 Then
          Rng.Characters.First.Next.Text = ChrW("&H03C5")
          Exit For
        End If
      Next
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Thanks, Paul!
In the same vein I thought of trying something like this
(<[άόέήίύώ])(*[άόέήίύώϊϋΰΐ]*>)
b\1c\2

Then use the added characters (b and c) to change first accented character to bold and then do a Find for all bold characters, mass change them to uppercase, mass change them to lowercase, and accent is gone.

My only problem is that the expression would span more than one word (for example it would find this "ότι η ομάδα"), i.e. I do not know how not to make it "greedy" or how to exclude space from the possible matches, trying [! ] did not seem to do the trick,

Try the following update - it should be much faster than the pervious versions. The reasons for that are twofold:
1. The Find expressions only find words that both begin with an accented character (or character pair in the case of εύ) and contain at least one more accented character, instead of just every word that starts with an accented character; and
2. The Execute expression uses ReplaceAll instead of having to process each found word individually.
The reason for there being four Find expressions character/pair is to cater for words that may (a) have an accented 2nd character; (b) have an accented 3rd or later character; and (c) words beginning with both lower & upper case. I haven't bothered with words that are entirely upper case, but I expect you can see from the code how that might be handled.

Sub Demo()
Application.ScreenUpdating = False
Dim ArrChr, StrStr As String, i As Long
Dim StrFnd1 As String, StrFnd2 As String
ArrChr = Array( _
  ChrW(&H3AC), ChrW(&H3B1), ChrW(&H3AD), ChrW(&H3B5), ChrW(&H3AE), _
  ChrW(&H3B7), ChrW(&H390), ChrW(&H3B9), ChrW(&H3CA), ChrW(&H3B9), _
  ChrW(&H3AF), ChrW(&H3B9), ChrW(&H3CC), ChrW(&H3BF), ChrW(&H3CD), _
  ChrW(&H3C5), ChrW(&H3B0), ChrW(&H3C5), ChrW(&H3CE), ChrW(&H3C9))
For i = 0 To UBound(ArrChr) Step 2
  StrStr = StrStr & ArrChr(i)
Next
StrFnd1 = "([" & StrStr & "])"
StrFnd2 = "([" & ChrW(&H3B1) & "-" & ChrW(&H3C9) & "]@[" & StrStr & "])"
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .MatchWildcards = True
  For i = 0 To UBound(ArrChr) Step 2
    .Replacement.Text = ArrChr(i + 1) & "\1"
    .Text = "<" & ArrChr(i) & StrFnd1
    .Execute Replace:=wdReplaceAll
    .Text = "<" & ArrChr(i) & StrFnd2
    .Execute Replace:=wdReplaceAll
    .Replacement.Text = UCase(ArrChr(i + 1)) & "\1"
    .Text = "<" & UCase(ArrChr(i)) & StrFnd1
    .Execute Replace:=wdReplaceAll
    .Text = "<" & UCase(ArrChr(i)) & StrFnd2
    .Execute Replace:=wdReplaceAll
  Next
  .Replacement.Text = "\1" & ChrW(&H3C5) & "\2"
  .Text = "<(" & ChrW(&H3B5) & ")" & ChrW(&H3CD) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & ChrW(&H3CD) & StrFnd2
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd2
  .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub

Yes, that works very well too, Paul, apart from missing "Εύτυχής" which was not missed by previous version. I wonder though why, in some Find/Replace code, when one has track changes on, you get entirely different results!

[QUOTE=greek;3668901]Yes, that works very well too, Paul, apart from missing "Εύτυχής" which was not missed by previous version.[QUOTE]
Oops! I capitalised the wrong character. Replace:

  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd2
  .Execute Replace:=wdReplaceAll

with:

  .Text = "<(" & UCase(ChrW(&H3B5)) & ")" & ChrW(&H3B5) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & UCase(ChrW(&H3B5)) & ")" & ChrW(&H3B5) & StrFnd2
  .Execute Replace:=wdReplaceAll

I wonder though why, in some Find/Replace code, when one has track changes on, you get entirely different results!

Track Changes has some unpredictable effects. Sometimes, for example, you need to change '.Forward = True' to '.Forward = False' to get the right result!

Amazing, yes much faster! I wish I could do something more to thank you for your help!

For some strange reason it misses Εύγούλα (but not εύγούλα).

By the way, I tried to add some extra vowel pairs (same functionality as for εύ -> ευ or Εύ -> Ευ)

αύ αυ
ού ου
εί ει
οί οι
αί αι

But when I tried something like this for αύ it did nothing.:

.Replacement.Text = "\1" & ChrW(&H3C5) & "\2"
  .Text = "<(" & ChrW(&H3B5) & ")" & ChrW(&H3CD) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & ChrW(&H3CD) & StrFnd2
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B1) & ")" & ChrW(&H3CD) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B1) & ")" & ChrW(&H3CD) & StrFnd2
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<(" & ChrW(&H3B5) & ")" & UCase(ChrW(&H3B5)) & StrFnd2
  .Execute Replace:=wdReplaceAll

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim ArrChr, StrStr As String, i As Long
Dim StrFnd1 As String, StrFnd2 As String
ArrChr = Array( _
  ChrW(&H3AC), ChrW(&H3B1), ChrW(&H3AD), ChrW(&H3B5), ChrW(&H3AE), _
  ChrW(&H3B7), ChrW(&H390), ChrW(&H3B9), ChrW(&H3CA), ChrW(&H3B9), _
  ChrW(&H3AF), ChrW(&H3B9), ChrW(&H3CC), ChrW(&H3BF), ChrW(&H3CD), _
  ChrW(&H3C5), ChrW(&H3B0), ChrW(&H3C5), ChrW(&H3CE), ChrW(&H3C9))
For i = 0 To UBound(ArrChr) Step 2
  StrStr = StrStr & ArrChr(i)
Next
StrFnd1 = "([" & StrStr & "])"
StrFnd2 = "([" & ChrW(&H3B1) & "-" & ChrW(&H3C9) & "]@[" & StrStr & "])"
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .MatchWildcards = True
  For i = 0 To UBound(ArrChr) Step 2
    .Replacement.Text = ArrChr(i + 1) & "\1"
    .Text = "<" & ArrChr(i) & StrFnd1
    .Execute Replace:=wdReplaceAll
    .Text = "<" & ArrChr(i) & StrFnd2
    .Execute Replace:=wdReplaceAll
    .Replacement.Text = UCase(ArrChr(i + 1)) & "\1"
    .Text = "<" & UCase(ArrChr(i)) & StrFnd1
    .Execute Replace:=wdReplaceAll
    .Text = "<" & UCase(ArrChr(i)) & StrFnd2
    .Execute Replace:=wdReplaceAll
  Next
  '
  .Replacement.Text = "\1" & ChrW(&H3C5) & "\2"
  .Text = "<([" & ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF) & "])" & ChrW(&H3CD) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF) & "])" & ChrW(&H3CD) & StrFnd2
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & UCase(ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF)) & "])" & ChrW(&H3CD) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & UCase(ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF)) & "])" & ChrW(&H3CD) & StrFnd2
  .Execute Replace:=wdReplaceAll
  '
  .Replacement.Text = "\1" & ChrW(&H3B9) & "\2"
  .Text = "<([" & ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF) & "])" & ChrW(&H3AF) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF) & "])" & ChrW(&H3AF) & StrFnd2
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & UCase(ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF)) & "])" & ChrW(&H3AF) & StrFnd1
  .Execute Replace:=wdReplaceAll
  .Text = "<([" & UCase(ChrW(&H3B1) & ChrW(&H3B5) & ChrW(&H3BF)) & "])" & ChrW(&H3AF) & StrFnd2
  .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub