Выборка номеров по диапазону

[EducatedFool]

Можно ли сделать так чтобы макрос копировал на отдельные листы нумерацию по станциям как на рисунке

Можно. Делайте.
Что именно не получается?

Хоть бы объяснили поподробнее - существуют ли на момент записи листы, на которые нужно переносить данные, или их надо создавать программно?
Сколько у вас АТС? всего 4, как в вашем коде, или может быть больше?


(добавлено)
Вот что получилось - проверяйте:

Sub Main()
    On Error Resume Next
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp)) ' диапазон номеров
    For Each cell In ra.Cells    ' перебираем все ячейки в столбце A
        SheetName = ATC_for_Number(cell)    ' получаем имя листа для номера из очередной ячейки
        If Len(SheetName) Then    ' если имя листа непустое, то
            ' если такого листа ещё нет - создаём его в конце книги
            If Not IsObject(Worksheets(SheetName)) Then Worksheets.Add(, ActiveSheet).Name = SheetName
            ' записываем номер в очередную пустую ячейку
            Worksheets(SheetName).Range("A" & Rows.Count).End(xlUp).Offset(1) = cell
        End If
    Next cell
End Sub

Function ATC_for_Number(ByVal pn As Variant) As String
    ' получает в качестве параметра номер телефона pn
    ' возвращает имя листа, на который надо поместить этот номер,
    ' или пустую строку, если номер не принадлежит ни одной АТС
    Select Case Val(pn)
        Case 440000 To 449999, 430000 To 430099, 430300 To 430949: ATC_for_Number = "ATC-44"
        Case 433000 To 433079, 433130 To 433179, 433185 To 433540: ATC_for_Number = "ATC-44"
        Case 434000 To 435999, 438000 To 439999, 450000 To 450899: ATC_for_Number = "ATC-44"
        Case 490000 To 499999, 310000 To 311286, 312000 To 312367, 432000 To 432999: ATC_for_Number = "ATC-44"

        Case 455000 To 455467, 455500 To 455511: ATC_for_Number = "ATC-455"

        Case 450900 To 450991, 460000 To 469999, 459000 To 459999: ATC_for_Number = "ATC-46"
        Case 436000 To 436299, 436600 To 436999, 455468 To 455499, 437000 To 437119: ATC_for_Number = "ATC-46"

        Case 451000 To 452021, 455842 To 455969, 452022 To 452499: ATC_for_Number = "ATC-451"
        Case 455540 To 455599, 455970 To 455999, 455600 To 455841: ATC_for_Number = "ATC-451"
    End Select
End Function

Пример в файле:

[zenner]

Спасибо огромное! Все работает идеально!

[zenner]

Прошу прощения но можно сделать так чтобы макрос захватывал и переносил вместе с номером и значения которое может находится (а может и не находится) рядом с ним в колонках B и C.
Файл прикрепляю: Обработка выключений.rar
СПАСИБО!!!

[EducatedFool]

надо заменить строку

Worksheets(SheetName).Range("B" & Rows.Count).End(xlUp).Offset(1) = cell

на строку

Worksheets(SheetName).Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = cell.Resize(, 3).Value

Проверяйте: http://excelvba.ru/XL_Files/Sample__...__17-10-25.zip

[zenner]

Вот теперь точно ВСЕ! Спасибо Вам большое еще раз!!!