Replace characters in array

[Sherzodom]

Hello,

I need a macro to replace latin letters to similar cyrillic letters.
This macro replaces only one letter. How to edit and replace all 11 letters. I am not good in arrays. Any help is appreciated.


Sub REPCHAR()
Dim Massive(2), DATA As Variant, RES As Variant, LC As String, I As Long, N As Long
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")

With Sheets("1")
LC = .Cells(.Rows.Count, "D").End(xlUp).Row
DATA = .Range("D1:E" & LC).Value
RES = .Range("D1:E" & LC).Value
For I = 1 To 2
If Not Dic.Exists(DATA(I, 2)) Then
Massive(2) = Replace(DATA(I, 2), "A", "А")
Massive(2) = Replace(DATA(I, 2), "B", "В")
Massive(2) = Replace(DATA(I, 2), "E", "Е")
Massive(2) = Replace(DATA(I, 2), "K", "К")
Massive(2) = Replace(DATA(I, 2), "M", "М")
Massive(2) = Replace(DATA(I, 2), "H", "Н")
Massive(2) = Replace(DATA(I, 2), "O", "О")
Massive(2) = Replace(DATA(I, 2), "P", "Р")
Massive(2) = Replace(DATA(I, 2), "C", "С")
Massive(2) = Replace(DATA(I, 2), "X", "Х")
Massive(2) = Replace(DATA(I, 2), "T", "Т")
Dic(DATA(I, 2)) = Massive
End If
Next I
For N = 1 To UBound(DATA)
On Error Resume Next
RES(N, 1) = Dic(DATA(N, 2))(2)
On Error GoTo 0
Next N

.Range("D1:E" & LC) = RES
End With
End Sub

[p45cal]

What are you trying to do?
It's impossible to work out what you want to happen with code that doesn't do what you want it to.
Best attach a small workbook with a few rows of cells with data and then elsewhere the expected outcome you want to see in columns D & E.

[Aussiebear]

When replacing multiple characters it may be better to go with the Substitute function than the Replace function. You can also nest Substitute as well. For example:


=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(Data(I, 2)"A","a"),"B","b"),"E","e"),"K","k"),"M","m")


Note your substituting old value for a new value, not "old value" with same "old value" as your code is suggesting

So, providing the rest of the code works as intended, this might assist

[Paul_Hossler]

Example of working with arrays




Option Explicit


Sub RepChar_1()


Dim DATA As Variant
Dim LC As Long, r As Long, c As Long

With Worksheets("1")
LC = .Cells(.Rows.Count, "D").End(xlUp).Row

DATA = .Range("D1:E" & LC).Value

For r = LBound(DATA, 1) To UBound(DATA, 1)
For c = LBound(DATA, 2) To UBound(DATA, 2)
DATA(r, c) = Replace(DATA(r, c), "A", "a") ' don't have cyrillic
DATA(r, c) = Replace(DATA(r, c), "B", "b")
DATA(r, c) = Replace(DATA(r, c), "C", "c")
DATA(r, c) = Replace(DATA(r, c), "D", "d")
DATA(r, c) = Replace(DATA(r, c), "E", "e")
DATA(r, c) = Replace(DATA(r, c), "F", "f")
DATA(r, c) = Replace(DATA(r, c), "G", "g")
DATA(r, c) = Replace(DATA(r, c), "H", "h")
DATA(r, c) = Replace(DATA(r, c), "I", "i")
DATA(r, c) = Replace(DATA(r, c), "J", "j")
DATA(r, c) = Replace(DATA(r, c), "K", "k")
DATA(r, c) = Replace(DATA(r, c), "L", "l")
Next c
Next r

.Range("D1:E" & LC).Value = DATA

End With
End Sub

[arnelgp]

you may also try this:



Sub REPCHAR()
Dim Massive(2), DATA As Variant, RES As Variant, LC As String, I As Long, N As Long
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")

Dim Latins As Variant
Dim Cyrillics As Variant

Latins = Array("A","B","E","K","M","H","O","P","C","X","T")
Cyrillics = Array("A","B","E","K","M","H","O","P","C","X","T")

With Sheets("1")
LC = .Cells(.Rows.Count, "D").End(xlUp).Row
DATA = .Range("D1:E" & LC).Value
RES = .Range("D1:E" & LC).Value
For I = 1 To 2
If Not Dic.Exists(DATA(I, 2)) Then
Massive(2) = DATA(I, 2)
For N = LBound(Latins) To Ubound(Latins)
Massive(2) = Replace$(Massive(2), Latins(N), Cyrillics(N))
Next
Dic(DATA(I, 2)) = Massive
End If
Next I
For N = 1 To UBound(DATA)
On Error Resume Next
RES(N, 1) = Dic(DATA(N, 2))(2)
On Error GoTo 0
Next N

.Range("D1:E" & LC) = RES
End With
End Sub

[Sherzodom]

Thanks to all of you for your answers. Special thanks to Paul_Hossler. His macro works perfect. First time here. Excellent website.

[Paul_Hossler]

Another variation, little shorter



Option Explicit

Sub RepChar_1()
Const sOld As String = "ABCDEFGHIJKL"
Const sNew As String = "abcdefghijkl"
Dim DATA As Variant
Dim LC As Long, r As Long, c As Long, x As Long
With Worksheets("1")
LC = .Cells(.Rows.Count, "D").End(xlUp).Row
DATA = .Range("D1:E" & LC).Value
For r = LBound(DATA, 1) To UBound(DATA, 1)
For c = LBound(DATA, 2) To UBound(DATA, 2)
For x = 1 To Len(sOld)
DATA(r, c) = Replace(DATA(r, c), Mid(sOld, x, 1), Mid(sNew, x, 1))
Next x
Next c
Next r
.Range("D1:E" & LC).Value = DATA
End With
End Sub

[Sherzodom]

Hello Paul,

After code performed, numbers like 123,456789 change to 123456789, i.e. commas deleted. Numbers with two digits after comma (123,12) not changed. And in numeric values dots replaced to commas i.e. 123.123 to 123,123.

Would be fine, if you can revise it.

[Paul_Hossler]

Try this

I believe that issue was caused by moving the cells to the array and then back from the array and the values went in with General formatting



Option Explicit

Sub RepChar_2()
Const sOld As String = "ABCDEFGHIJKL"
Const sNew As String = "abcdefghijkl"
Dim rData As Range
Dim iLast As Long, r As Long, c As Long, x As Long
With Worksheets("1")
iLast = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rData = .Range("D1:E" & iLast)
With rData
For r = 1 To .Rows.Count
For c = 1 To .Columns.Count
If VarType(.Cells(r, c).Value) = vbString Then ' <<<<<<<<<<<<<<<<
For x = 1 To Len(sOld)
.Cells(r, c).Value = Replace(.Cells(r, c).Value, Mid(sOld, x, 1), Mid(sNew, x, 1))
Next x
End If
Next c
Next r
End With
End With
End Sub