Compare and replace- Long Sentences

[kitwit]

Hi,

I have a list of values in English (original( and in another sheet i have the list translation values English and it its french translation. I want to compare the between the English values and if they match then replace the english values with the french words. This script works well below for single words, however when i use it for long phrases; it get error 13 mismatch. Can someone help how to fix this. most of my comparison is Long phrases. not just one or 2 words.

Sub MultiFindNReplace()'Update 20140722Dim Rng As Range
Dim InputRng As Range, ReplaceRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Original Range ", xTitleId, InputRng.Address, Type:=8)
Set ReplaceRng = Application.InputBox("Replace Range :", xTitleId, Type:=8)
Application.ScreenUpdating = False
For Each Rng In ReplaceRng.Columns(1).Cells
InputRng.Replace what:=Rng.Value, _
                 replacement:=Rng.Offset(0, 1).Value, _
                 LookAt:=xlWhole
                 
Next
Application.ScreenUpdating = True
End Sub

[mancubus]

welcome to the forum.

can you post your workbook?
(#2 in my signature)

[Paul_Hossler]

@kitwit --

Word by word, or phrase by idiomatic phrase?

[kitwit]

On sheet 1, i would like to replace column A (original)- sheet1 with the translated text from Column B in the translated sheet.

As you can see the text are long phrases.


Another requirement i have is, let say once the translation is completed in sheet1, i would like the values that were translated to be highlighted green. This will be an visual indicator that will tell me which of those values were translated in sheet1. How would i do that, this is not that important i want the code to work first before this

[kitwit]

I have also use this code, same thing, single word it replaces fine but long phrase doesn't seems to work. I keep getting mismatch error.

 Option ExplicitSub Multi_FindReplace()
    Dim sRng As Range, InputRng As Range, ReplaceRng As Range, Cls As Range, Rg0 As Range
    Dim MyAdd$, xTitleId$
    
    xTitleId = "ERS : Applying Abbriviation"
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Select the Columns to Apply Stanards ", xTitleId, InputRng.Address, Type:=8)
    Set ReplaceRng = Application.InputBox("Standard Abbreviations Sheet Range (Col A and ColB):", xTitleId, Type:=8)
    Application.ScreenUpdating = False
    
    For Each Cls In ReplaceRng.Columns(1).Cells
        Set sRng = InputRng.Find(Cls.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            MyAdd = sRng.Address
            Do
                If Rg0 Is Nothing Then
                    Set Rg0 = sRng
                Else
                    Set Rg0 = Union(Rg0, sRng)
                End If
                Set sRng = InputRng.FindNext(sRng)
            Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        End If
        If Not Rg0 Is Nothing Then
            Rg0.Value = Cls.Offset(, 1).Value
            Set Rg0 = Nothing
        End If
    Next Cls
    Application.ScreenUpdating = True
End Sub

[Paul_Hossler]

This could be more efficient, but the increased complexity for imperceptible performance improvement didn't seem worthwhile

Be advised that the text has to match EXACTLY -- no fuzzy logic

You can add your UI InputBox logic, etc.

Option Explicit

Sub TranslateEngFr()
    Dim rEngFr As Range, rEng As Range, r As Range
    Dim s As String
    
    Set rEngFr = Worksheets("Translated").Cells(1, 1).CurrentRegion
    Set rEng = Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(1)
    
    Application.ScreenUpdating = False
    
    For Each r In rEng.Cells
        s = vbNullString
        On Error Resume Next
        s = Application.WorksheetFunction.VLookup(r.Value, rEngFr, 2, False)
        On Error GoTo 0
        
        If Len(s) > 0 Then
            r.Value = s
            r.Interior.Color = vbGreen
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

[kitwit]

This could be more efficient, but the increased complexity for imperceptible performance improvement didn't seem worthwhile

Be advised that the text has to match EXACTLY -- no fuzzy logic

You can add your UI InputBox logic, etc.

Option Explicit

Sub TranslateEngFr()
    Dim rEngFr As Range, rEng As Range, r As Range
    Dim s As String
    
    Set rEngFr = Worksheets("Translated").Cells(1, 1).CurrentRegion
    Set rEng = Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(1)
    
    Application.ScreenUpdating = False
    
    For Each r In rEng.Cells
        s = vbNullString
        On Error Resume Next
        s = Application.WorksheetFunction.VLookup(r.Value, rEngFr, 2, False)
        On Error GoTo 0
        
        If Len(s) > 0 Then
            r.Value = s
            r.Interior.Color = vbGreen
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

Thanks how come there are some row in sheet1 with the exact match of sentence in the translation sheet, did not endup being translated in sheet 1, for example row 1, 5, 20, 21.

[Paul_Hossler]

The text was longer that the WS function Match could handle

Capture.JPG


Plan B -- Not quite as simple, but performance is still just as good -- give this a shot

Option Explicit

Sub TranslateEngFr2()
    Dim rEngFr As Range, rEng As Range, r As Range, r2
    Dim iEng As Long
    
    Set rEng = Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(1)
    Set rEngFr = Worksheets("Translated").Cells(1, 1).CurrentRegion
    
    
    Application.ScreenUpdating = False
    
    For Each r In rEng.Cells
        For Each r2 In rEngFr.Rows
            If r.Value = r2.Cells(1, 1).Value Then
                r.Value = r2.Cells(1, 2).Value
                r.Interior.Color = vbGreen
                Exit For
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
End Sub

[SamT]

Paul,

Put the English to be translated into an array, Put the French values into another,
Split the Eng2Fr Column Cells into a 2D array of single words

Then something like

For i = LBound to Ubound(arrEng)
  arrTemp = Split(arrEng(i))
  UB = Ubound(arrTemp)
  For j = lbound to ubound(arrEng2Fr)
    'Quick Test
    If UBound(arrEng2Fr(j) = UB then
      'Full test
      For k = Lbound to Ubound(arrTemp) + 1
         If K = UB Then 'They must match 'cuz we're still here
           arrEng(i) = arFrench(i)
           GoTo Next_arrEng
         End If
         If arrTemp(k) Not arrEng2Fr(k) then  Exit For  'Nope. Not a match.       
      Next k
    End If
  Next j
Next_arrEng:
Next i

'Replace English to be translated column with arrEng

[Paul_Hossler]

Paul,

Put the English to be translated into an array, Put the French values into another, Split the Eng2Fr Column Cells into a 2D array of single words

I didn't feel that the increase in complexity for such a simple task was worth it

1000 entries runs in less than a second

1. K.I.S.S

2.

quote-premature-optimization-is-the-root-of-all-evil-donald-knuth-72-10-20.jpg

[kitwit]

Thank you everyone, this was exactly what i was looking for, just out of curiosity, why didn't 2 above script i posted didn't work and gave me mismatch?

[SamT]

That wasn't optimization...That was just fixing the String Length issue. I see that you fixed it another way later in the thread.

[Paul_Hossler]

That wasn't optimization...That was just fixing the String Length issue. I see that you fixed it another way later in the thread.

Sorry - anytime someone says "Use arrays" I think "Optimization"

Besides, I was looking for a place to use my Knuth quote slide

[kitwit]

Hi, I use Paul code, however when i try to use and apply this to 90,000 cells, it takes for-ever and just freeze.. i have a pretty fast machine, the ryzen threadripper, 12 core, 24 threads processor. Is there a way to optimize this code below?

Option Explicit

Sub TranslateEngFr2()
    Dim rEngFr As Range, rEng As Range, r As Range, r2, InputRng As Range
    Dim iEng As Long
    Dim MyAdd$, xTitleId$
    
    Set InputRng = Application.Selection
    Set rEng = Application.InputBox("Which column do want to convert:", xTitleId, Type:=8)
    Set rEngFr = Application.InputBox("translation dictionary ", xTitleId, InputRng.Address, Type:=8)
    
    
    Application.ScreenUpdating = False
    
    For Each r In rEng.Cells
        For Each r2 In rEngFr.Rows
            If r.Value = r2.Cells(1, 1).Value Then
                r.Value = r2.Cells(1, 2).Value
                r.Interior.Color = vbGreen
                Exit For
            End If
        Next
    Next
    
    Application.ScreenUpdating = True


End Sub

[kitwit]

Can someone please help with this? i am not able to get this to work with Large set of data.

Hi, I use Paul code, however when i try to use and apply this to 90,000 cells, it takes for-ever and just freeze.. i have a pretty fast machine, the ryzen threadripper, 12 core, 24 threads processor. Is there a way to optimize this code below?

Option Explicit

Sub TranslateEngFr2()
    Dim rEngFr As Range, rEng As Range, r As Range, r2, InputRng As Range
    Dim iEng As Long
    Dim MyAdd$, xTitleId$
    
    Set InputRng = Application.Selection
    Set rEng = Application.InputBox("Which column do want to convert:", xTitleId, Type:=8)
    Set rEngFr = Application.InputBox("translation dictionary ", xTitleId, InputRng.Address, Type:=8)
    
    
    Application.ScreenUpdating = False
    
    For Each r In rEng.Cells
        For Each r2 In rEngFr.Rows
            If r.Value = r2.Cells(1, 1).Value Then
                r.Value = r2.Cells(1, 2).Value
                r.Interior.Color = vbGreen
                Exit For
            End If
        Next
    Next
    
    Application.ScreenUpdating = True


End Sub