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

22390


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.

22393

[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" :thumb

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

[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