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

[zenner]

Добрый день!К нам приходит данный список DECON.rar номеров на выключение, но это список номеров всех АТС а мне нужно выбрать только номера нашей АТС.Помогите пожалуйста с макросом который оставит только номера с диапазоном 440000-449999, 312000-312299.Хотелось бы чтобы гдето сбоку была бы кнопка "ОБРАБОТАТЬ" Спасибо!!!
Безымянный.png

[AChrist]

Sub Кнопка1_Щелчок()
Application.ScreenUpdating = False

For Each cell In Range("A:A")

If cell.Value < 312000 Or cell.Value > 312299 And cell.Value < 440000 Or cell.Value > 449999 Then
cell.Delete
End If

Next cell



End Sub

Попробуйте. Хотя я думаю, другие пользователи помогут Вам этот макрос ускорить.

[SAS888]

Корректнее и существенно быстрее так:

Sub Main()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.Count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If (a(i, 1) >= 440000 And a(i, 1) <= 449999) Or (a(i, 1) >= 312000 And a(i, 1) <= 312299) Then
            b(j, 1) = a(i, 1): j = j + 1
        End If
    Next: x.Value = b
End Sub

Пример во вложении.

[zenner]

Спасибо Вам !!!

[zenner]

Я хочу добавить еще 20 диапазонов и просто добавляю в одну строку
Or (a(i, 1) >= 430000 And a(i, 1) <= 430099) но так как диапазонов много они не помещаются в одну строку а что надо написать чтобы каждый диапазон писать с новой строки примерно так:

If (a(i, 1) >= 440000 And a(i, 1) <= 449999)
If (a(i, 1) >= 430000 And a(i, 1) <= 430099)
If (a(i, 1) >= 455540 And a(i, 1) <= 455599)

[EducatedFool]

Я хочу добавить еще 20 диапазонов

Я в вашем случае вынес бы проверку на принадлежность номера к вашей АТС в отдельную функцию:

Function IsOurNumber(ByVal pn As Variant) As Boolean
    ' возвращает TRUE, если номер pn принажлежит нашей АТС
    IsOurNumber = False
    If (Len(pn) < 5 Or Len(pn) > 6) Or Not IsNumeric(pn) Then Exit Function
    Select Case val(pn) Mod 100000
        Case 17000 To 17999, 18025, 18028 To 19026: IsOurNumber = True
        Case 38000 To 38999, 79000 To 82599: IsOurNumber = True
            ' ...
        Case 96000 To 96499: IsOurNumber = True
        Case 97900 To 97999: IsOurNumber = True
    End Select
End Function

А потом использовал бы её так (в коде от SAS888):

Sub Main()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If IsOurNumber(a(i, 1)) Then b(j, 1) = a(i, 1): j = j + 1
    Next: x.Value = b
End Sub

[zenner]

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

Я в вашем случае вынес бы проверку на принадлежность номера к вашей АТС в отдельную функцию:

Function IsOurNumber(ByVal pn As Variant) As Boolean
    ' возвращает TRUE, если номер pn принажлежит нашей АТС
    IsOurNumber = False
    If (Len(pn) < 5 Or Len(pn) > 6) Or Not IsNumeric(pn) Then Exit Function
    Select Case val(pn) Mod 100000
        Case 17000 To 17999, 18025, 18028 To 19026: IsOurNumber = True
        Case 38000 To 38999, 79000 To 82599: IsOurNumber = True
            ' ...
        Case 96000 To 96499: IsOurNumber = True
        Case 97900 To 97999: IsOurNumber = True
    End Select
End Function

А потом использовал бы её так (в коде от SAS888):

Sub Main()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If IsOurNumber(a(i, 1)) Then b(j, 1) = a(i, 1): j = j + 1
    Next: x.Value = b
End Sub

Так что и с чем мне нужно склеить???

[EducatedFool]

Так что мне нужно склеить???

Заменить это:

Sub Main()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If (a(i, 1) >= 440000 And a(i, 1) <= 449999) Or (a(i, 1) >= 312000 And a(i, 1) <= 312299) Then
            b(j, 1) = a(i, 1): j = j + 1
        End If
    Next: x.Value = b
End Sub

на это:

Sub Main()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If IsOurNumber(a(i, 1)) Then b(j, 1) = a(i, 1): j = j + 1
    Next: x.Value = b
End Sub

Function IsOurNumber(ByVal pn As Variant) As Boolean
    ' возвращает TRUE, если номер pn принажлежит нашей АТС
    Select Case val(pn)
        Case 440000 To 449999, 430000 To 430099: IsOurNumber = True
            ' ...
        Case 455540 To 455599, 312000 To 312299: IsOurNumber = True
    End Select
End Function

[zenner]

Спасибо большое!!!

[zenner]

Я добавил все диапазоны и получилось следующее:

PHP код:

Private Sub CommandButton1_Click()
    Dim i As Long, j As Long, x As Range, a(), b(): Application.ScreenUpdating = False
    Set x = Range([A1], Cells(Rows.Count, 1).End(xlUp)): a = x.Value
    ReDim b(1 To UBound(a, 1), 1 To 1): j = 1
    For i = 1 To UBound(a, 1)
        If IsOurNumber(a(i, 1)) Then b(j, 1) = a(i, 1): j = j + 1
    Next: x.Value = b
End Sub

Function IsOurNumber(ByVal pn As Variant) As Boolean
    ' âîçâðàùàåò TRUE, åñëè íîìåð pn ïðèíàæëåæèò íàøåé ÀÒÑ
    Select Case Val(pn)
         Case 440000 To 449999: IsOurNumber = True 'ATC-44
         Case 430000 To 430099: IsOurNumber = True 'ATC-44
         Case 430300 To 430949: IsOurNumber = True 'ATC-44
         Case 433000 To 433079: IsOurNumber = True 'ATC-44
         Case 433130 To 433179: IsOurNumber = True 'ATC-44
         Case 433185 To 433540: IsOurNumber = True 'ATC-44
         Case 434000 To 435999: IsOurNumber = True 'ATC-44
         Case 438000 To 439999: IsOurNumber = True 'ATC-44
         Case 450000 To 450899: IsOurNumber = True 'ATC-44
         Case 490000 To 499999: IsOurNumber = True 'ATC-44
         Case 310000 To 311286: IsOurNumber = True 'ATC-44
         Case 312000 To 312367: IsOurNumber = True 'ATC-44
         Case 432000 To 432999: IsOurNumber = True 'ATC-44
         
         Case 455000 To 455467: IsOurNumber = True 'ATC-455
         Case 455500 To 455511: IsOurNumber = True 'ATC-455
         
         Case 450900 To 450991: IsOurNumber = True 'ATC-46
         Case 460000 To 469999: IsOurNumber = True 'ATC-46
         Case 459000 To 459999: IsOurNumber = True 'ATC-46
         Case 436000 To 436299: IsOurNumber = True 'ATC-46
         Case 436600 To 436999: IsOurNumber = True 'ATC-46
         Case 455468 To 455499: IsOurNumber = True 'ATC-46
         Case 437000 To 437119: IsOurNumber = True 'ATC-46
         
         Case 451000 To 452021: IsOurNumber = True 'ATC-451
         Case 455842 To 455969: IsOurNumber = True 'ATC-451
         Case 452022 To 452499: IsOurNumber = True 'ATC-451
         Case 455540 To 455599: IsOurNumber = True 'ATC-451
         Case 455970 To 455999: IsOurNumber = True 'ATC-451
         Case 455600 To 455841: IsOurNumber = True 'ATC-451
    End Select
End Function 


В скобках я указал какой диапазон к какой станции принадлежит.
Можно ли сделать так чтобы макрос копировал на отдельные листы нумерацию по станциям как на рисунке:
Без.png