Цифры можно откинуть и проверкой на IsNumeric()  
Т.е. попробуйте так:  
 
Sub Translate()  
   Dim cell1, cell2 As Range  
   Dim i, Langs As Long  
 
   Langs = 2    'количество языков перевода (включая русский)  
 
   For Each cell1 In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)  
       If Not IsNumeric(cell1.Value) Then  
           For Each cell2 In Worksheets("Dict").Cells.SpecialCells(xlCellTypeConstants)  
               If cell1.Value = cell2.Value Then  
                   i = cell2.Column  
                   If i = Langs Then i = 1 Else i = i + 1  
                   cell1.Value = Worksheets("Dict").Cells(cell2.Row, i).Value  
                   GoTo 1  
               End If  
           Next cell2  
       End If  
1:             Next cell1  
   End Sub  
 
Но с объявлением переменных вероятно непорядок...

Да и словарь можно в словарь поместить - тогда вообще всего два прохода по массиву будет - сперва загоняем в словарь словарь, потом по словарю проверяем массив слов.  
А если словарь сделать публичным - то можно ещё сэкономить на каждом запуске кода.  
Вот такая тавтология :)

Вы не правильно объявляете переменные, нужно НЕ так  
 
Dim cell1, cell2 As Range  
Dim i, Langs As Long  
 
 
А так  
 
Dim cell1 As Range, cell2 As Range  
Dim i As Long, Langs As Long

Вы бы всё-таки сделали бы небольшой пример, строк на 10-20. А мы бы вам макрос быстрый бы сделали

а вам нужно переводить всегда с русского на английский, или и туда и обратно?

{quote}{login=Flash}{date=16.11.2011 07:36}{thema=}{post}Попробуйте так  
 
Sub Translate()  
   Dim DicArray(), iCell As Range, Rng As Range, i As Long  
 
   FromRusIntoEng = False  
   With Worksheets("Dict")  
       DicArray() = .Range("A1:B" & .[B1].End(xlDown).Row).Value
   End With  
   Set Rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 2)  
   Application.ScreenUpdating = False  
   For Each iCell In Rng  
       For i = 1 To UBound(DicArray)  
           'с русского на английский  
           If iCell.Value = DicArray(i, 2) Then  
               iCell.Value = DicArray(i, 1)  
               Exit For  
           End If  
           'с английского на русский  
           If iCell.Value = DicArray(i, 1) Then  
               iCell.Value = DicArray(i, 2)  
               Exit For  
           End If  
       Next i  
   Next iCell  
   Application.ScreenUpdating = True  
   MsgBox "Перевод выполнен!", vbInformation, "Конец"  
End Sub{/post}{/quote}  
 
Ой, лепота! Перевод прямо летает! Большущее Вам спасибо, Flash!  Буду разбираться в макросе - кое-что тут для меня новое есть. Еще раз спасибо огромное!!!

Добавил в словарь до 1000 пар слов, погонял варианты на словах из примера и моём тысячном:  
 
TranslOrig: 5,421875  
TranslOrig: 3,453125  
TranslOrig: 3,359375  
TranslOrig: 8,234375  
TranslOrig: 3,390625  
TranslFlash: 1,25  
TranslFlash: 1,09375  
TranslFlash: 1,1875  
TranslHugo: 0,140625  
TranslHugo: 0,125  
TranslHugo: 0,109375  
TranslHugo: 0,125  
 
Все 3 варианта ниже.  
Я чуть схитрил - словари (русский и английский) создаются только при первом запуске кода.  
Если переводить нужно всего лишь раз - то это нужно убрать, чтоб в памяти не висело.  
А если переводить нужно часто - то словари можно создать при открытии книги.  
Но если словарь на листе будете пополнять - то нужно или ещё раз открыть книгу, или обновить DicDic'и  
С другой стороны - если слов не много, то это такая мелочь, что словари можно создавать при каждом запуске и убивать по окончании, т.е.    
перенести первые две строки примера в Sub TranslateHugo()  
Что ещё - при первом запуске может не перевести, если FromRusIntoEng будет не соответствовать состоянию на листе.  
Пробовал все слова класть в один DicDic - тогда переключатель не нужен, но будет и смесь слов переводить на противоположные.  
Но в общем вполне рабочий вариант - и код проще, и работать будет чуть быстрее, только нужно самому отслеживать, чтоб на листе одновременно не было где-нибудь  
Date и Дата  
Таймер в рабочем варианте стоит закомментировать - лишнее.  
 
 
 
Dim DicDicE As Object  
Dim DicDicR As Object  
Dim FromRusIntoEng As Boolean  
 
Sub TranslateHugo()  
   Dim tm: tm = Timer  
   Dim DicArray(), iCell As Range, Rng As Range, i As Long  
 
   FromRusIntoEng = Not FromRusIntoEng  
 
   If DicDicE Is Nothing Then  
 
       With Worksheets("Dict")  
           DicArray() = .Range("A1:B" & .[B1].End(xlDown).Row).Value
       End With  
 
       Set DicDicE = CreateObject("Scripting.Dictionary")  
       Set DicDicR = CreateObject("Scripting.Dictionary")  
         
       With DicDicE  
           .CompareMode = vbTextCompare  
           For i = 1 To UBound(DicArray)  
               .Item(DicArray(i, 1)) = DicArray(i, 2)  
           Next  
       End With  
 
       With DicDicR  
           .CompareMode = vbTextCompare  
           For i = 1 To UBound(DicArray)  
               .Item(DicArray(i, 2)) = DicArray(i, 1)  
           Next  
       End With  
   End If  
 
 
   Set Rng = Sheets("Share price").UsedRange.SpecialCells(xlCellTypeConstants, 2)  
   Application.ScreenUpdating = False  
 
If FromRusIntoEng Then  
   With DicDicE  
       For Each iCell In Rng  
           If .exists(iCell.Value) Then iCell.Value = .Item(iCell.Value)  
       Next iCell  
   End With  
Else  
   With DicDicR  
       For Each iCell In Rng  
           If .exists(iCell.Value) Then iCell.Value = .Item(iCell.Value)  
       Next iCell  
   End With  
End If  
 
   Application.ScreenUpdating = True  
   Debug.Print "TranslHugo: " & Timer - tm  
   '    MsgBox "Перевод выполнен!", vbInformation, "Конец"  
End Sub  
 
 
 
 
 
 
 
Sub TranslateOrig()  
   Dim tm: tm = Timer  
   Dim cell1 As Range, cell2 As Range  
   Dim i As Long, Langs As Long  
 
   Langs = 2    'количество языков перевода (включая русский)  
 
   For Each cell1 In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)  
       For Each cell2 In Worksheets("Dict").Cells.SpecialCells(xlCellTypeConstants, 2)  
           If cell1.Value = cell2.Value Then  
               i = cell2.Column  
               If i = Langs Then i = 1 Else i = i + 1  
               cell1.Value = Worksheets("Dict").Cells(cell2.Row, i).Value  
               GoTo 1  
           End If  
       Next cell2  
1:         Next cell1  
   Debug.Print "TranslOrig: " & Timer - tm  
End Sub  
 
 
Sub TranslateFlash()  
   Dim tm: tm = Timer  
   Dim DicArray(), iCell As Range, Rng As Range, i As Long  
 
   FromRusIntoEng = False  
   With Worksheets("Dict")  
       DicArray() = .Range("A1:B" & .[B1].End(xlDown).Row).Value
   End With  
   Set Rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 2)  
   Application.ScreenUpdating = False  
   For Each iCell In Rng  
       For i = 1 To UBound(DicArray)  
           'с русского на английский  
           If iCell.Value = DicArray(i, 2) Then  
               iCell.Value = DicArray(i, 1)  
               Exit For  
           End If  
           'с английского на русский  
           If iCell.Value = DicArray(i, 1) Then  
               iCell.Value = DicArray(i, 2)  
               Exit For  
           End If  
       Next i  
   Next iCell  
   Application.ScreenUpdating = True  
   Debug.Print "TranslFlash: " & Timer - tm  
   '    MsgBox "Перевод выполнен!", vbInformation, "Конец"  
End Sub

Да просто самому интересно было, как выйдет :)  
А что там проверять - файл выше, код замените на то, что я выложил, слов побольше навалите...  
Я так просто протянул  
 
word1 слово1  
word2 слово2  
 
Потом переводил word994 :)  
 
Там выше фразу не дописал, хотел так:  
"обновить DicDic'и отдельным кодом".

а если объявление словарей    
 
   Dim DicDicE As Object  
   Dim DicDicR As Object  
 
перенести внутрь самой процедуры, то получается немного медленнее, но не намного  
 
Hugo - 0.093 (вместо 0,015)  
 
Но всё равно конечно быстрее с Dictionery

сходите ка по ссылке: http://www.planetaexcel.ru/forum.php?thread_id=8763