Translating letters from english to russian

Please, help to finish macro. It has to work in sheet "INFO".

Code:

---

russA1=""
dlina = Len( A1 )
'Сначала обрабатываем самые "длинные" буквы:
i = 1
do while i<= dlina
    r = ""
    s = lcase$(Mid$( A1, i, 2 ))
    Select case True
              case s = "ch": r = "ч"
              case s = "sh": r = "ш"
              case s = "zg": r = "ж"
              ' и так далее
    End Select
    'Проверю, малоли буква большая была:
    s = Mid$( A1, i, 2 )
    if ucase$(left$(s,1))=left$(s,1) then r=ucase$(r)
    russA1 = russA1 + r
    i=i+1
loop

i = 1
do while i<= dlina
    r = ""
    s = lcase$(Mid$( A1, i, 1 ))
    Select case True
              case s = "a": r = "а"
              case s = "b": r = "б"
              case s = "c": r = "ц"
              case s = "d": r = "д"
              ' и так далее
    End Select
    'Проверю, малоли буква большая была:
    s = Mid$( A1, i, 1 )
    if ucase$(left$(s,1))=left$(s,1) then r=ucase$(r)
    russA1 = russA1 + r
    i=i+1
loop

---

thanks in advance

Try the change
[VBA]
russA1 = russA1 + r

[/VBA]
to
[VBA]
russA1 = russA1 & r

[/VBA]

Suleyman,

I am only a newbie to VBA, but this is a nice homework problem.

If you place this code in Module1, it will work on any active sheet in any active Workbook. If placed in This Workbook Module, It will work on any active sheet in this workbook. If placed in "Info" Worksheet Module, It will Only work on Info."


[VBA]

Sub ChangeChars()

'To change 1 or 2 Characters in a String to 1 different character
'Runs down Column A, changing words as needed

Dim CellIndex As Long ' To Point to Working Cell
Dim ThisCell As Range ' ThisCell is Working Cell
Dim LastRow As Long ' Need code to find last cell in Col(A). You write this.
Dim Russ1 As String ' To hold Original String
Dim Russ1Len As Long ' to hold Length of Original String
Dim Russ2 As String ' To hold New String
Dim CharIndex As Long 'To Point to Working Character
Dim s As String ' To hold Working Character
Dim r As String 'To hold New Character

Let CellIndex = 1
Set ThisCell = "A" & CellIndex
Let LastRow = 'LastRow Code

Do While Not(CellIndex > LastRow)
Russ1 = ThisCell.Value
Russ1Len = Len(Russ1)
Russ2 = ""
If Russ1Len <> 0 Then 'If Cell Empty Then Skip Character Changing
CharIndex = 1
Do While Not(CharIndex > Russ1Len)
s = Mid(Russ1, CharIndex, 1)
Select Case True
Case s = "c" And Mid(Russ1, CharIndex + 1, 1) = h: _
r = 'New Lower Case Character. I can't do Russian Fonts
CharIndex = CharIndex + 2 'We checked 2 characters

Case s = "C" And Mid(Russ1, CharIndex + 1, 1) = h: _
r = 'New upper Case Character
CharIndex = CharIndex + 2

'Case s And h repeat 2 primary Case statements here.
'Case z And g repeat without "And" Statement

Case s = "a": _
r = 'New Lower Case Character
CharIndex = CharIndex + 1 'We checked 1 character
Case s = "A" : _
r = 'New upper Case Character
CharIndex = CharIndex + 1

'Case b, c, or d, etc. repeat above

Case Else _
s = Mid(Russ1, Charindex, 1)
CharIndex = CharIndex + 1
End Select
Russ2 = Russ2 & r ' Append new Character to new String

Loop 'Check next Character
End If

Russ1 = Russ2 'This replaces original word in Column(A) with changed version.

CellIndex = CellIndex + 1
Loop 'Check next Cell

End Sub




[/VBA]