Макрос для сортировки

[pupszu]

Добрый день всем.
Уважаемые программисты, прошу помощи.
Каждый месяц от оператора связи приходит детализация телефонных звонков. Мне нужно все номера переименовать в направления. Сотовые телефоны будут разделены на два типа - "Санкт-Петербург (моб.)" и "Россия (моб.)", оставшиеся (не сотовые) телефоны будут разделены на города и страны (Санкт-Петербург, Москва, Урюпинск, США, Тайвань и т.д.).
Я понял как мне выявить и переименовать города и страны - ячейка проверяется на наличие того или иного кода с помощью цикла и присваивает нужное значение. Вот код

Sub ReplaceCellsData()
  Dim cell As Range
  ' Просмотр всех ячеек диапазона и замена искомого текста
  For Each cell In [D1:D1500]
     If cell.Value Like "8812*" Then
        cell.Value = "Санкт-Петербург"
   End If
  For Each cell In [D1:D1500]
     If cell.Value Like "8495*" Then
        cell.Value = "Москва"
   End If
  Next
End Sub

Проблема возникла с сотовыми операторами. Чтобы выявить питерский это номер или нет, надо проверить номер на принадлежность к нескольким диапазонам. Примерно так

Sub ReplaceCellsData()
  Dim cell As Range
  'Проверяю каждую ячейку на попадание в диапазон питерского Мегафона
  For Each cell In [D1:D1500]
     If cell.Value Like "Диапазон от 89210900000  до  89210999999" Then
        cell.Value = "Санкт-Петербург (моб.)"
   End If
  For Each cell In [D1:D1500]
     If cell.Value Like "Диапазон от 89211110000  до  89211119999" Then
        cell.Value = "Санкт-Петербург (моб.)"
   End If
 'поторяю верхние циклы для всех известных диапазонов питерского Мегафона
 'Так как предыдущими циклами я выбрал и переименовал все телефоны с кодом 921, попадающие в диапазон питера, то все остальные телефоны с кодом 921 можно автоматом переименовать в "Россия (моб.)"
  For Each cell In [D1:D1500]
     If cell.Value Like "*8921*" Then
        cell.Value = "Россия (моб.)"
   End If
'Далее я буду проверять точно таким же образом все остальные коды - сначала питерские диапазоны переименую в "Санкт-Петербург (моб.)", а все остальные в "Россия (моб.)"
  Next
End Sub

Я не знаю как мне написать проверку на принадлежность к диапазону If cell.Value Like "Диапазон от 89210900000 до 89210999999" Then
Помогите, пожалуйста.

[EducatedFool]

Тут немного другой алгоритм надо применять - тогда код будет быстрее и проще.

Выкладывайте свой файл (исходные данные + список соответствия диапазонов городам) - посмотрим, что можно сделать.

Надо использовать Select Case - приблизительно так:

Select Case cell 
        Case 89210900000  To 89210999999 ' выполняется первое условие
            cell.Value = "Санкт-Петербург (моб.)"
        ' и т.д.
    End Select

Хотя и так можно:

For Each cell In [D1:D1500]
     If cell.Value Like "8921111####" Then
        cell.Value = "Санкт-Петербург (моб.)"
   End If

[RAN.]

If cell.Value Like "892109*" Then ?

[pupszu]

Сообщение от EducatedFool

Тут немного другой алгоритм надо применять - тогда код будет быстрее и проще.
Надо использовать Select Case - приблизительно так:

Ничуть не спорю, если вы считаете, что так будет быстрее и лучше, то попробую так.
Файлик приложил - там маленький кусочек данных и малая часть соответствий (их еще целиком не делал)

По второму предложению понял. Чет я туплю, действительно же можно так

[pupszu]

Сообщение от RAN.

If cell.Value Like "892109*" Then ?

Да, спасибо. Сразу не сообразил, что можно и так сделать

[pupszu]

Сообщение от EducatedFool

Надо использовать Select Case - приблизительно так:

Что-то не работает. Никаких ошибок не выдает, но и ничего не меняет

[pupszu]

Всем еще раз доброго дня.
Накатал я макрос, и он даже работает
Беда только в том, что ручной работы с ним почти столько же, как при ручной сортировке... Уже сейчас там 196 вот таких циклов

For Each cell In [E1:E1500]
    If cell.Value Like "81081*" Then
       cell.Value = "Япония"
    End If
  Next

И это наверняка еще не конец, их надо будет добавлять почти каждый месяц. Как все это упростить у меня есть идея, но сам я такое реализовать точно не смогу, поэтому прошу помощи.
Итак идея: два экселевских файла - один со статистикой, другой с табличкой "код-легенда". Макрос берет из файла2 код, проверяет в заданном столбце файла1 все ячейки на наличие этого кода и, там где они есть, заменяет значение текущей ячейки в файле1 на соответствующее значение легенды из файла2.
К сожалению сам я такое написать не смогу

[IgorGO]

формула не подойдет?

[Казанский]

Циклы на самом деле не нужны. Достаточно

Columns("B").Replace "8921*", "Россия (моб.)"

Другое дело, что строки поиска надо отсортировать по длине, и сначала заменять более длинные строки. Иначе смотрите, например

8831	Н.Новгород
883130	Саров

Если сначала заменить 8831*, то в обоих случаях будет Н.Новгород.

[Казанский]

Примерно так. Файл "code-legend.xlsx" должен находиться в папке с открытым файлом:

Sub pupszu()
Dim i, ash As Worksheet
Set ash = ActiveSheet
On Error Resume Next
With Workbooks.Open(ActiveWorkbook.Path & "\code-legend.xlsx", ReadOnly:=True).Worksheets("исходники")
    If Err Then MsgBox "Не удалось открыть файл с таблицей", vbCritical: Exit Sub
    i = Cells.SpecialCells(xlCellTypeLastCell).Row
    .Range("C2:C" & i).Formula = "=LEN(A2)"
    .Range("A2:C" & i).Sort .Range("C2"), xlDescending, Header:=xlNo
    ash.Activate
    For Each i In .Range("A2:A" & i)
        Range("B:B").Replace i & "*", i.Offset(, 1)
    Next
    .Parent.Close False
End With
End Sub