Автофильтр / Microsoft Office

ReSQL.ru

Мобильная версия Контакт Правила FAQ Помощь

Гость

Войти | Регистрация | Профиль | Очистить

Новые сообщения | Избранное

Форумы | Пользователи | Статистика | Мод. лог | Поиск

Цитировать

Написать

Автор*:

Ввести пароль для входа

Тема*:

Сообщение

Данное сообщение тематическое

Сообщение содержит картинки или видео 18+

Автор:

ВНИМАНИЕ! На данном подфоруме действуют строгие правила. Удостоверьтесь, что ваше сообщение соответствует им!

Форум или тема закрыты для гостей. Необходима авторизация!

Загрузить последнюю сохраненную версию

Вложение:

Вставить как галерею

Максимальный размер вложений: 4,0 МБ, аудио/видео: 8,0 МБ. Картинки большего размера ужимаются, если возможно.

Введите код, изображенный на картинке. Если код нечитаемый, кликните картинку, чтобы загрузить другой вариант.

Отправляя сообщение, я выражаю свое согласие с правилами форума и принимаю пользовательское соглашение.

Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Автофильтр

51 сообщений из 51, показаны все 3 страниц

все

Автофильтр

#34806269

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.

Sub FilTR()
Worksheets("K1").Activate

With ActiveSheet
            .AutoFilterMode = False
                With .Range("a1:bb1")
                    .AutoFilter
                     .AutoFilter Field:= 10 , Criteria1:="T?2"
                    
                     .AutoFilter Field:= 3 , Criteria1:="C?????-K", _
                     Operator:=xlAnd, Criteria2:="C?????-A"
                End With
    End With
End Sub

Фильтрую по 2 колонкам, причём в 3-ем столбце применяю одновременно 2 критерия. Алгоритм не работает, однако если использовать 1 критерий (в 3-ем столбце) и 1 критерий в 10-ом столбце, то всё в порядке.

Подскажите, пожалуйста, где я ошибся.

...

Рейтинг:

0 / 0

17.09.2007, 19:29:41

| Ответить | Цитировать | Написать

Автофильтр

#34806548

lena_###

Гость

nPUBET

Вместо

Код: plaintext

Operator:=xlAnd

попробуйте

Код: plaintext

Operator:=xlOr

...

Рейтинг:

0 / 0

17.09.2007, 23:28:18

| Ответить | Цитировать | Написать

Автофильтр

#34807233

nPUBET

Гость

lena_###
Вместо

Код: plaintext

Operator:=xlAnd

попробуйте

Код: plaintext

Operator:=xlOr

lena_###

Спасибо.
Получилось.

...

Рейтинг:

0 / 0

18.09.2007, 11:10:10

| Ответить | Цитировать | Написать

Автофильтр

#34807791

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.

Sub OTRIC()
Worksheets("K1").Activate

    Const List1 = "K1"
     Dim i As Integer
     Dim otricatel As Integer  '********
    Dim mList( 2 ) As String
    Dim dr As Integer
    Dim xlSh1 As Worksheet, rng As Range
    mList( 0 ) = "No."
    dr = ActiveSheet.UsedRange.Rows.Count
    Set xlSh1 = Worksheets(List1)
'** здесь фильтрую таблицу по 3-ему и 10-ому столбцам
      
    For i =  0  To UBound(mList)  'перехожу в столбец "No."
        Set rng = xlSh1.Range("1:1").Find(mList(i), xlSh1.Range("A1"), LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
        If Not rng Is Nothing Then
'        rng.Cells(dr, "1").Interior.ColorIndex = 37
        xlSh1.Cells(dr,  1 ).Interior.ColorIndex =  37 

'
'                    For otricatel = 1 To dr
'
''
'                    Next otricatel
            
        Else
            MsgBox "ne najden stolbec " & Chr$( 34 ) & mList(i) & Chr$( 34 )
        End If
    Next
    Application.CutCopyMode = False
    MsgBox "Stolbec " & Chr$( 34 ) & mList( 0 ) & Chr$( 34 ) & " najden"

End Sub

С этим макросом ищу столбец с названием "No."
Дальше не смог сформулировать.

Пытаюсь сделать следующее:
- в цикле

Код: plaintext

For otricatel =  1  To dr...Next otricatel

ищу в столбце "No." одинаковые значения в абсолютном выражении, т.е. например "1204,3" и "-1204,3". Далее перехожу в строку с отрицательным значением, т.е. "-1204,3" и удаляю строку целиком.
Подскажите, пожалуйста, как это сделать?

...

Рейтинг:

0 / 0

18.09.2007, 13:15:36

| Ответить | Цитировать | Написать

Автофильтр

#34808667

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

Нужен другой алгоритм.
Предлагаю так.
Организовываем доп. столбец (в примере - "M") в который вставляем формулу "ABS", дальше делаем сортировку по доп. столбцу и столбцу "K" ("No.") после этого устанавливаем фильтр и делаем пробег по отфильтрованным строкам с проверкой, на раменство, предыдущей ячейки с последующей и если они равны накапливаем в массив, а после пробега удаляем. А затем очищаем доп. столбец. Мда...
Вообщем разберись с кодом.

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.

Private Sub OTRIC()

    Dim i As Integer, fil As Filter, xlSh1 As Worksheet, rng As Range, rng2 As Range, rng3 As Range
    
    
    Set xlSh1 = ActiveSheet
    With xlSh1
        If .AutoFilterMode Then 'проверка стоит ли фильтр
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For 'проверка стоит ли критерий
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter 'включение автофильтра
        End If
        ' вставка формулы (по модулю) в доп столбец
        .Range(.Cells( 2 ,  13 ), .Cells(.Cells(Rows.Count,  11 ).End(xlUp).Row,  13 )).FormulaR1C1 = "=ABS(RC[-2])"
        'сортировка по доп столбцу и столбцу "No."
        .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  13 ).End(xlUp).Row,  15 )).Sort Key1:=.Range("M2"), Order1:=xlAscending, Key2:=.Range("K2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom
        ' выставляем фильтр
        .Range("A1").AutoFilter Field:= 10 , Criteria1:="T?2"
        .Range("A1").AutoFilter Field:= 3 , Criteria1:="C?????-K", _
            Operator:=xlOr, Criteria2:="C?????-A"

        'отбираем отфильтрованные строки
        Debug.Print
        Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        'пробег по отфильтрованным строкам
        For Each rng2 In rng
            If rng2 = rng2.Offset( 1 ,  0 ) Then
                If rng2.Offset( 0 , - 2 ) <  0  Then
                    If rng3 Is Nothing Then
                        Set rng3 = rng2
                    Else
                        Set rng3 = Union(rng3, rng2)
                    End If
                End If
            End If
        Next
        If Not rng3 Is Nothing Then rng3.EntireRow.Delete
        .Range("M:M").ClearContents
    End With
End Sub

P.S. столбец "No." д.б. в "К"

...

Рейтинг:

0 / 0

18.09.2007, 16:17:52

| Ответить | Цитировать | Написать

Автофильтр

#34808914

nPUBET

Гость

vkodor
Спасибо за алгоритм!

...извиняюсь, я немного не так обьяснил...
1. Сортирую.
2. Перехожу в 3-й столбец ("Участок").
3. Ищу в этом столбце одинаковые номера по следуюшему критерию

Код: plaintext

       .AutoFilter Field:= 3 , Criteria1:="=*?????-A*", _
                     Operator:=xlOr, Criteria2:="=*?????-K*"

4. Образую области обработки для каждого номера по критерию отдельно (на рисунке они - разными цветами).
- т.е. с 2-ой по 9-ю строки - это номера, которые подходят под номер "C10001-А*" (см. рис.)
- с 10-ой по 15-ю строки - "E10399-K*"
- с 16-ой по 45-ю строки - "C10145-A*"

5. Если номер в 3-ем столбце нижней строки не подходит по критерию, перехожу в 11-ый столбец (т.е. иду с 9 строки 3-го столбца во 2-ю строку 11-го столбца - т.к. область обработки для "C10001-А*" находится в промежутке с 2-ой по 9-ую строки).

6. Здесь (т.е. только для "C10001-А*") ищу одинаковые значения в абсолютном выражении.
7. Eсли сумма 2-х значений (одинаковых в абсолюте) равна нулю (в суммировании участвуют только две ячейки), то строки с этими значениями удаляю.

В итоге, если всё просчитаю, от строк на рисунке останется только две.

...

Рейтинг:

0 / 0

18.09.2007, 17:05:40

| Ответить | Цитировать | Написать

Автофильтр

#34808924

nPUBET

Гость

Вот файл.

...

Рейтинг:

0 / 0

18.09.2007, 17:07:08

| Ответить | Цитировать | Написать

Автофильтр

#34808973

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

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

Код: plaintext

1.
2.
3.
4.
5.
6.

    If rng3 Is Nothing Then
        Set rng3 = rng2
        Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))
    Else
        Set rng3 = Union(rng3, rng2)
        Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))
    End If

...

Рейтинг:

0 / 0

18.09.2007, 17:18:42

| Ответить | Цитировать | Написать

Автофильтр

#34809057

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

работает только критерий надо подправить

Код: plaintext

        .Range("A1").AutoFilter Field:= 3 , Criteria1:="*?????-K**", _
            Operator:=xlOr, Criteria2:="=*?????-A**"

...

Рейтинг:

0 / 0

18.09.2007, 17:39:15

| Ответить | Цитировать | Написать

Автофильтр

#34809116

nPUBET

Гость

Спасибо!

Изучаю...

...

Рейтинг:

0 / 0

18.09.2007, 17:50:34

| Ответить | Цитировать | Написать

Автофильтр

#34809343

nPUBET

Гость

...у меня такой pезультат: остается 3 строки (см. рис.).

Я многое в VBA пока не понимаю.
Объясни, пожалуйста, что выполняется в отдельных строках Твоего алгоритма (выделил по частям).

1 Часть:

Код: plaintext

1.
2.
3.
4.
5.

  If .AutoFilterMode Then '
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For '
            Next
....
        End If

2 Часть:

Код: plaintext

1.
2.
3.

 .Range(.Cells( 2 ,  13 ), .Cells(.Cells(Rows.Count,  11 ).End(xlUp).Row,  13 )).FormulaR1C1 = "=ABS(RC[-2])"
         .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  13 ).End(xlUp).Row,  15 )).Sort Key1:=.Range("M2"), Order1:=xlAscending, Key2:=.Range("K2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom

3 Часть:

Код: plaintext

1.
2.

Debug.Print
        Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        For Each rng2 In rng

4 Часть:

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.

            If rng2 = rng2.Offset( 1 ,  0 ) Then
                If rng2.Offset( 0 , - 2 ) <  0  Then
                '************
                       If rng3 Is Nothing Then
                            Set rng3 = rng2
                            Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))
                        Else
                            Set rng3 = Union(rng3, rng2)
                            Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))  
                       End If ....

5 Часть:

Код: plaintext

  If Not rng3 Is Nothing Then rng3.EntireRow. ...

...

Рейтинг:

0 / 0

18.09.2007, 18:49:24

| Ответить | Цитировать | Написать

Автофильтр

#34809407

nPUBET

Гость

Файл с тремя строками...

...

Рейтинг:

0 / 0

18.09.2007, 19:09:00

| Ответить | Цитировать | Написать

Автофильтр

#34810925

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.

Sub FiltP()
Sheets("K1").Activate

Dim iNteg As Integer
Dim fil As Filter
Dim xlSh1 As Worksheet
Dim rng As Range

    Set xlSh1 = ActiveSheet
    With xlSh1
    '********
            If .AutoFilterMode Then
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter '
        End If
'******???
'    .Range("a1").AutoFilter Field:="No*", Criteria1:="T?2"  'Error1004
'
'    .Range("a1").AutoFilter Field:="PT*", Criteria1:="*?????-A**", Operator:=xlOr, _
'    Criteria2:="*?????-K**"
'******???
    End With
End Sub

фильтрую не по номеру столбца, а по названию столбца. Макрос выдаёт ошибку:
Error 1004 (Autofilter method of Range Class).

Подскажите, пожалуйста, как фильтровать столбцы динамически, т.е. по названию столбца, не используя в "Field:=" числа, а названия столбцов.
Файл с "Еrror 1004" приложил.

...

Рейтинг:

0 / 0

19.09.2007, 12:54:23

| Ответить | Цитировать | Написать

Автофильтр

#34811102

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

1 Часть:

Код: plaintext

1.
2.
3.
4.
5.

  If .AutoFilterMode Then '
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For '
            Next
....
        End If

If .AutoFilterMode Then - если .AutoFilterMode = True (на листе включен автофильтр) тогда
For Each fil In .AutoFilter.Filters - пробег по всем колонкам фильтра
If fil.On Then .ShowAllData: Exit For - если колонка отфильтрована то снимаем фильтр со всех колонок и выходим из цикла

2 Часть:

Код: plaintext

1.
2.
3.

 .Range(.Cells( 2 ,  13 ), .Cells(.Cells(Rows.Count,  11 ).End(xlUp).Row,  13 )).FormulaR1C1 = "=ABS(RC[-2])"
         .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  13 ).End(xlUp).Row,  15 )).Sort Key1:=.Range("M2"), Order1:=xlAscending, Key2:=.Range("K2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom

.Range(.Cells(2, 13), .Cells(.Cells(Rows.Count, 11).End(xlUp).Row, 13)).FormulaR1C1 = "=ABS(RC[-2])" - вставка в Ячейки начиная с .Cells(2, 13) (вторая строка 13-ый столбец) до .Cells(.Cells(Rows.Count, 11).End(xlUp).Row, 13) (нижняя заполненая строка по 11-му столбцу 13-ый столбец) формулу "=ABS(RC[-2])" возвращающую модуль (абсолютную величину) числа из -2 столбца (т.е. 11-го)
3 Часть:

Код: plaintext

1.
2.

Debug.Print
        Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
        For Each rng2 In rng

присваиваем переменной "rng" не скрытые (xlCellTypeVisible) ячейки столбца "М"
For Each rng2 In rng - присваиваем поочереди переменной rng2 ячейки из переменной rng

4 Часть:

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.

            If rng2 = rng2.Offset( 1 ,  0 ) Then
                If rng2.Offset( 0 , - 2 ) <  0  Then
                '************
                       If rng3 Is Nothing Then
                            Set rng3 = rng2
                            Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))
                        Else
                            Set rng3 = Union(rng3, rng2)
                            Set rng3 = Union(rng3, rng2.Offset( 1 ,  0 ))  
                       End If ....

если выполняются условия, то накапливаем в rng3 нужные ячейки

5 Часть:

Код: plaintext

  If Not rng3 Is Nothing Then rng3.EntireRow. ...

если rng3 не пуста то удаляем строки содержащие ячейки накопленные в rng3

...

Рейтинг:

0 / 0

19.09.2007, 13:30:17

| Ответить | Цитировать | Написать

Автофильтр

#34811220

nPUBET

Гость

vkodor1 Часть:

Код: plaintext

  If .AutoFilterMode Then '
             ...

если rng3 не пуста то удаляем строки содержащие ячейки накопленные в rng3

Спасибо!

...может у Тебя есть идеи по "...Range("a1").AutoFilter Field=.." не по числам?

nPUBET, 19.09, 12:54 cм.

...

Рейтинг:

0 / 0

19.09.2007, 13:52:25

| Ответить | Цитировать | Написать

Автофильтр

#34811752

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

идея только одна, поскольку невозможно в свойстве Field обращаться не по номеру, надо через find искать номер столбца.
примерно так

Код: plaintext

1.
2.
3.

    i = .Range("1:1").Find("PT", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=i, Criteria1:="*?????-A**", Operator:=xlOr, _
    Criteria2:="*?????-K**"

...

Рейтинг:

0 / 0

19.09.2007, 15:55:21

| Ответить | Цитировать | Написать

Автофильтр

#34811949

nPUBET

Гость

vkodorидея только одна, поскольку невозможно в свойстве Field обращаться не по номеру, надо через find искать номер столбца.
примерно так

Код: plaintext

1.
2.
3.

    i = .Range("1:1").Find("PT", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=i, Criteria1:="*?????-A**", Operator:=xlOr, _
    Criteria2:="*?????-K**"

Спасибо за идею!
Пока у меня выглядит так. Cортирует, но строки не удаляет (думаю, дело в номерах столбцов).
Поэтому cейчас занимаюсь заменой номеров и букв столбцов (11, 13, 15, "M2:M", "K2",...) на iPT.

Код: plaintext

Sub OTRIC_2()
Sheets("K1").Activate
    Dim i As Integer, fil As Filter, xlSh1 As Worksheet, rng As Range, rng2 As Range, rng3 As Range
        
    Set xlSh1 = ActiveSheet
    With xlSh1
        If .AutoFilterMode Then '
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For '
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter '
        End If
        
        '************
        Dim iNo As Long
        Dim iPT As Long
        
        iPT = .Range("1:1").Find("PT*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iPT, Criteria1:="*?????-A**", Operator:=xlOr, _
    Criteria2:="*?????-K**"
    
          iNo = .Range("1:1").Find("AB*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iNo, Criteria1:="T?2"
    


        '*******************
         .Range(.Cells( 2 ,  13 ), .Cells(.Cells(Rows.Count,  11 ).End(xlUp).Row,  13 )). _ 
         FormulaR1C1 = "=ABS(RC[-2])"
        
        .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  13 ).End(xlUp).Row,  15 )). _ 
        Sort Key1:=.Range("M2"), Order1:=xlAscending, Key2:=.Range("K2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom
        
        '*************
        '
        Debug.Print
        Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row). _ 
       SpecialCells(xlCellTypeVisible)
        '
        For Each rng2 In rng
            If rng2 = rng2.Offset( 1 ,  0 ) Then
                If rng2.Offset( 0 , - 2 ) <  0  Then
                    If rng3 Is Nothing Then
                        Set rng3 = rng2
                    Else
                        Set rng3 = Union(rng3, rng2)
                    End If
                End If
            End If
        Next
        If Not rng3 Is Nothing Then rng3.EntireRow.Delete
        .Range("M:M").ClearContents
    End With
End Sub

...

Рейтинг:

0 / 0

19.09.2007, 16:38:54

| Ответить | Цитировать | Написать

Автофильтр

#34812533

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.

Sub OTRIC_2()
Sheets("K1").Activate
    Dim i As Integer, fil As Filter, xlSh1 As Worksheet, rng As Range, rng2 As Range, rng3 As Range
        
    Set xlSh1 = ActiveSheet
    With xlSh1
        If .AutoFilterMode Then
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter '
        End If
        
        '************
        Dim iAB As Long
        Dim iPT As Long
        Dim iNo As Long
        
           iNo = .Range("1:1").Find("No*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
        
        iPT = .Range("1:1").Find("PT*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iPT, Criteria1:="*?????-A**", Operator:=xlOr, _
    Criteria2:="*?????-K**"
    
          iAB = .Range("1:1").Find("AB*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iAB, Criteria1:="T?2"

        '*******************
         .Range(.Cells( 2 ,  33 ), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  33 )).FormulaR1C1 = "=ABS(RC[-22])"  '*****!!!!!!!
        
        .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  33 ).End(xlUp).Row,  35 )).Sort Key1:=.Cells( 2 ,  33 ), _
        Order1:=xlAscending, Key2:=.Cells( 2 , iNo) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom
        '*************
    End With
End Sub

С =Union= мне трудновато. Удаление решил делать по-другому (позже покажу).
Вычисления =ABS(RC[-22])= делаю в 33-ом столбце (на всякий случай).
Код наверху работает.
А вот вариант строки внизу не проходит.
.Range(.Cells(2, 33), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row, 33)).FormulaR1C1 = "=ABS(RC[Cells(2,iNo)])"Т.е не могу привязать =ABS(RC[-22])= к переменной =iNo=.
Как связать =ABS(RC[-22])= с переменной =iNo=?

...

Рейтинг:

0 / 0

19.09.2007, 19:05:35

| Ответить | Цитировать | Написать

Автофильтр

#34813191

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

Код: plaintext

.Range(.Cells( 2 ,  33 ), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  33 )).FormulaR1C1 = "=ABS(RC[" & iNo -  33  & "])"

...

Рейтинг:

0 / 0

20.09.2007, 08:45:44

| Ответить | Цитировать | Написать

Автофильтр

#34815852

nPUBET

Гость

vkodor

Код: plaintext

.Range(.Cells( 2 ,  33 ), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  33 )).FormulaR1C1 = "=ABS(RC[" & iNo -  33  & "])"

vkodor
Большое спасибо!

Вот работает...

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.

Sub OTRIC_2()
Sheets("K1").Activate
    Dim i As Integer, fil As Filter, xlSh1 As Worksheet, rng As Range, rng2 As Range, rng3 As Range
        
    Set xlSh1 = ActiveSheet
    With xlSh1
        If .AutoFilterMode Then
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter '
        End If
        
        '************
        Dim iAB As Long
        Dim iPT As Long
        Dim iNo As Long
        
           iNo = .Range("1:1").Find("No*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
        
        iPT = .Range("1:1").Find("PT*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iPT, Criteria1:="*?????-A**", Operator:=xlOr, _
    Criteria2:="*?????-K**"
    
          iAB = .Range("1:1").Find("AB*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iAB, Criteria1:="T?2"

        '******************* "=ABS(RC[-22])"
'         .Range(.Cells(2, 33), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row, 33)).FormulaR1C1 = "=ABS(RC[-22])"
         .Range(.Cells( 2 ,  33 ), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  33 )).FormulaR1C1 = "=ABS(RC[" & iNo -  33  & "])"

         .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  33 ).End(xlUp).Row,  35 )).Sort Key1:=.Cells( 2 ,  33 ), _
        Order1:=xlAscending, Key2:=.Cells( 2 , iNo) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom
        
        '*************
'        Sub Udalenie()

        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  33 ).End(xlUp).Row
            For iK =  2  To konec
                For jK = iK +  1  To konec +  1 
                  If Cells(iK,  33 ).Value = Cells(jK,  33 ).Value Then
                    Cells(iK,  33 ).Interior.ColorIndex =  45 
                    Cells(jK,  33 ).Interior.ColorIndex =  45 
                    Else
                       End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  33 ).Interior.ColorIndex =  45  Then
                        Cells(k,  33 ).EntireRow.Delete
                      End If
                    Next k
              Range(Cells( 2 ,  33 ), Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  33 )).ClearContents
        
            Application.ScreenUpdating = True
    
'End Sub
                    

    End With
End Sub

...

Рейтинг:

0 / 0

20.09.2007, 19:17:48

| Ответить | Цитировать | Написать

Автофильтр

#34817253

nPUBET

Гость

Часть верхнего алгоритма =Sub OTRIC_2()=

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.

......
      ....
        '************
        Dim iAB As Long
        Dim iPT As Long
.......
 iAB = .Range("1:1").Find("AB*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iAB, Criteria1:="T?2"
.....
False, Orientation:=xlTopToBottom
        
'        '*************
'        Sub Udalenie()

        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  43 ).End(xlUp).Row
            '**********
            For Each iAB In ActiveSheet   '********  <<<<<<
            '*********
            For iK =  2  To konec
                For jK = iK +  1  To konec +  1 
                  If Cells(iK,  43 ).Value = Cells(jK,  43 ).Value Then
                    Cells(iK,  43 ).Interior.ColorIndex =  45 
                    Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.Delete
                      End If
                    Next k
                    '*******
            Next  '********  <<<<<
                    '******
              Range(Cells( 2 ,  43 ), Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  43 )).ClearContents
.....

выдаёт ошибку:"Переменная =iAB= должна иметь тип Variant или Object".
Подскажите, пожалуйста, как активировать =Sub Udalenie()= только для переменных =iAB=?

...

Рейтинг:

0 / 0

21.09.2007, 12:09:38

| Ответить | Цитировать | Написать

Автофильтр

#34817424

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.

       .....
 False, Orientation:=xlTopToBottom
        
'        '*************
'        Sub Udalenie()

        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  43 ).End(xlUp).Row
'            '**********
'            Dim CellAB As Range
'            For Each Cell In Cells.SpecialCells(xlCellTypeVisible)
            Dim cAB As Object
'            Application.Volatile
'            For Each Cell In cAB
                If Not Rows.Hidden Then
'                    If Not Cells.Hidden Then
            '*********
            For iK =  2  To konec
                For jK = iK +  1  To konec +  1 
                  If Cells(iK,  43 ).Value = Cells(jK,  43 ).Value Then
                    Cells(iK,  43 ).Interior.ColorIndex =  45 
                    Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.ClearContents
                      End If
                    Next k
                    '*******
'                    End If
                End If
'            Next
.....
                    '******

...так тоже не работает.

Подскажите, пожалуйста, как активировать =Sub Udalenie()= только для переменных =iAB=?

...

Рейтинг:

0 / 0

21.09.2007, 12:51:46

| Ответить | Цитировать | Написать

Автофильтр

#34817690

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

nPUBET
выдаёт ошибку:"Переменная =iAB= должна иметь тип Variant или Object".

iAB = .Range("1:1").Find("AB*", LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

здесь используется метод "find" обьекта "Range" и возвращается номер столбца "Column"
следовательно переменная д.б. long, но если метод "Find" не найдет нужного значения (в данной ситуации "AB*"), то будет вызываться ошибка, поэтому обычно делают так:
объявляют переменную типа range

Код: plaintext

Dim rng3 As Range

затем присваивают ей результат метода find

Код: plaintext

Set rng = .Range("1:1").Find("AB*", xlSh1.Range("A1"), LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

и затем проверяют (найдено или нет)

Код: plaintext

        If Not rng Is Nothing Then iAB = rng.Column Else Exit sub

nPUBET
Подскажите, пожалуйста, как активировать =Sub Udalenie()= только для переменных =iAB=?

Это как? Что-то не понятно.

...

Рейтинг:

0 / 0

21.09.2007, 13:42:21

| Ответить | Цитировать | Написать

Автофильтр

#34817913

nPUBET

Гость

vkodor
nPUBET
Подскажите, пожалуйста, как активировать =Sub Udalenie()= только для переменных =iAB=?

Это как? Что-то не понятно.
....запускаю =Sub OTRIC_2()= (всего около 10.000 строк, после сортировки остаётся видимых строк около 100), не могу дождаться конца (жду 6 минут, потом принудительно прерываю).
Т.е. =Sub OTRIC_2()= для 40 строк очень хорош, а вот если строк немного побольше (ок. 10.000) - то он уже не так эффективен.

Понимаете, пытаюсь сделать следующее:
1. Сортирую
2. Считаю по функции ="=ABS(RC[" & iNo - 33 & "])"= в 33-ом столбце.
3. Смотрю в столбец под номером =iAB=:
- если в этом столбце есть ячейки со значением =T?2=, тогда удаляю эти строки;
- если значение другое, прохожу мимо.

Т.е. хотел бы запускать =Sub Udalenie()= в =Sub OTRIC_2()= только для видимых строк.
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?

...

Рейтинг:

0 / 0

21.09.2007, 14:17:28

| Ответить | Цитировать | Написать

Автофильтр

#34818072

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

nPUBET
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?
Конечно можно, и это у тебя уже было.

Код: plaintext

Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row). _ 
       SpecialCells(xlCellTypeVisible)

если хочешь удалить все отобранные автофильтром строки это так

Код: plaintext

.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete

...

Рейтинг:

0 / 0

21.09.2007, 14:46:56

| Ответить | Цитировать | Написать

Автофильтр

#34818277

nPUBET

Гость

vkodor nPUBET
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?
Конечно можно, и это у тебя уже было.

Код: plaintext

Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row). _ 
       SpecialCells(xlCellTypeVisible)

если хочешь удалить все отобранные автофильтром строки это так

Код: plaintext

.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete

Извиняюсь, если на так обьяснил.

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.

        False, Orientation:=xlTopToBottom
'        '*************
'        Sub Udalenie()

        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  43 ).End(xlUp).Row
'            '**********
''            Dim CellAB As Range
''            For Each Cell In Cells.SpecialCells(xlCellTypeVisible)
'            Dim cAB As Object
''            Application.Volatile
''            For Each Cell In cAB
'                If Not Rows.Hidden Then
''                    If Not Cells.Hidden Then
Dim fromRng As Range
Dim iRow As Range

Set fromRng = xlSh1.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each iRow In fromRng   ' 
            For iK =  2  To konec
                For jK = iK +  1  To konec +  1 
                If Cells(iK,  43 ) =  0  Then
                
                  If Cells(iK,  43 ).Value = Cells(jK,  43 ).Value Then
                    Cells(iK,  43 ).Interior.ColorIndex =  45 
                    Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                      End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.ClearContents
                      End If
                    Next k
                    '*******

        Next iRow
....
                    '******

Вот вариант для =Sub Udalenie()= в =Sub OTRIC_2()=, однако этот берёт всю таблицу на обработку ...
Т.е. пытаюсь пристроить условие в =Sub Udalenie()=, чтобы весь =Sub Udalenie()= действовал только для видимых строк. И только если значения видимых строк в 33-ом столбце одинаковые, только тогда удаляю эти строки. А скрытые строки не трогаю

...

Рейтинг:

0 / 0

21.09.2007, 15:38:11

| Ответить | Цитировать | Написать

Автофильтр

#34818983

nPUBET

Гость

Код: plaintext

1.
2.
3.
4.
5.
6.
7.

        
If Cells(iK,  33 ).Value ( 8 ,) = Cells(jK,  33 ).Value ( 8 ,) Then  ' ***здесь ошибка***
Cells(iK,  33 ).Interior.ColorIndex =  45   ' процедурa А
Cells(jK,  33 ).Interior.ColorIndex =  45 
Else
' процедурa Б
End If

Подскажите, пожалуйста, как сравнить значения 2-х ячеек по расположению знаков?

...формулирую следующее условие:
- если первые 8 знаков ячеек одинаковые, тогда выполняю процедуру А,
- если первые 8 знаков неодинаковые, тогда - процедуру Б.
Например, сравниваю А1="Д10003- А ", А2="Д10003- А ГТ" (подходит процедурa А).
В случае c A16="Д10003-А", A17="Д10003- B ГТ" (подходит процедурa Б).

...

Рейтинг:

0 / 0

21.09.2007, 19:49:42

| Ответить | Цитировать | Написать

Автофильтр

#34819084

Deggasad

Участник

Откуда: Воронеж

Сообщения: 3 509

Рейтинг: 0 / 0

Код: plaintext

1.
2.
3.
4.

If LEFT(Cells(iK,  33 ).Value , 8 ) = LEFT(Cells(jK,  33 ).Value , 8 ) Then 
' процедурa А
Else
' процедурa Б
End If

...

Рейтинг:

0 / 0

21.09.2007, 21:30:50

| Ответить | Цитировать | Написать

Автофильтр

#34824499

nPUBET

Гость

Deggasad

Код: plaintext

1.
2.
3.
4.

If LEFT(Cells(iK,  33 ).Value , 8 ) = LEFT(Cells(jK,  33 ).Value , 8 ) Then 
' процедурa А
Else
' процедурa Б
End If

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

Подскажите, пожалуйста, следующее условие:
если ячейка Cells(iK, 33) содержит только 8 знаков, тогда процедура А,
если больше или меньше 8 знаков, тогда процедура Б.

Код: plaintext

1.
2.
3.
4.

If LEFT(Cells(iK,  33 ).Value , 8 ) = "8" Then 'так не получается
' процедурa А  (ячейка Cells(iK, 33) содержит только 8 знаков)
Else
' процедурa Б (ячейка Cells(iK, 33) содержит больше или меньше 8 знаков)
End If

...

Рейтинг:

0 / 0

25.09.2007, 14:17:49

| Ответить | Цитировать | Написать

Автофильтр

#34824554

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

Код: plaintext

1.
2.
3.
4.

If Len(Cells(iK,  33 ).Value) =  8  Then 
' процедурa А  (ячейка Cells(iK, 33) содержит только 8 знаков)
Else
' процедурa Б (ячейка Cells(iK, 33) содержит больше или меньше 8 знаков)
End If

...

Рейтинг:

0 / 0

25.09.2007, 14:26:36

| Ответить | Цитировать | Написать

Автофильтр

#34824798

nPUBET

Гость

vkodor

Код: plaintext

1.
2.
3.
4.

If Len(Cells(iK,  33 ).Value) =  8  Then 
' процедурa А  (ячейка Cells(iK, 33) содержит только 8 знаков)
Else
' процедурa Б (ячейка Cells(iK, 33) содержит больше или меньше 8 знаков)
End If

Спасибо! Работает...

...

Рейтинг:

0 / 0

25.09.2007, 15:12:51

| Ответить | Цитировать | Написать

Автофильтр

#34824893

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

nPUBET vkodor nPUBET
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?
Конечно можно, и это у тебя уже было.

Код: plaintext

Set rng = .Range("M2:M" & .Cells(Rows.Count,  11 ).End(xlUp).Row). _ 
       SpecialCells(xlCellTypeVisible)

если хочешь удалить все отобранные автофильтром строки это так

Код: plaintext

.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete

Извиняюсь, если на так обьяснил.

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.

        False, Orientation:=xlTopToBottom
'        '*************
'        Sub Udalenie()

        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  43 ).End(xlUp).Row
'            '**********
''            Dim CellAB As Range
''            For Each Cell In Cells.SpecialCells(xlCellTypeVisible)
'            Dim cAB As Object
''            Application.Volatile
''            For Each Cell In cAB
'                If Not Rows.Hidden Then
''                    If Not Cells.Hidden Then
Dim fromRng As Range
Dim iRow As Range

Set fromRng = xlSh1.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each iRow In fromRng   ' 
            For iK =  2  To konec
                For jK = iK +  1  To konec +  1 
                If Cells(iK,  43 ) =  0  Then
                
                  If Cells(iK,  43 ).Value = Cells(jK,  43 ).Value Then
                    Cells(iK,  43 ).Interior.ColorIndex =  45 
                    Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                      End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.ClearContents
                      End If
                    Next k
                    '*******

        Next iRow
....
                    '******

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.

Set fromRng = xlSh1.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
            kk = fromRng.Rows.Count
            For iK =  1  To kk
                For jK = iK +  1  To kk
                If fromRng.Cells(iK,  43 ) =  0  Then
                
                  If fromRng.Cells(iK,  43 ).Value = fromRng.Cells(jK,  43 ).Value Then
                    fromRng.Cells(iK,  43 ).Interior.ColorIndex =  45 
                    fromRng.Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                      End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.ClearContents
                      End If
                    Next k
                    '*******

        Next iRow

...

Рейтинг:

0 / 0

25.09.2007, 15:28:00

| Ответить | Цитировать | Написать

Автофильтр

#34824948

nPUBET

Гость

vkodor

попробуй так

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.

Set fromRng = xlSh1.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
            kk = fromRng.Rows.Count
            For iK =  1  To kk
                For jK = iK +  1  To kk
                If fromRng.Cells(iK,  43 ) =  0  Then
                
                  If fromRng.Cells(iK,  43 ).Value = fromRng.Cells(jK,  43 ).Value Then
                    fromRng.Cells(iK,  43 ).Interior.ColorIndex =  45 
                    fromRng.Cells(jK,  43 ).Interior.ColorIndex =  45 
                    Else
                       End If
                      End If
                Next jK
            Next iK
                    For k = konec To  1  Step - 1 
                        If Cells(k,  43 ).Interior.ColorIndex =  45  Then
                        Cells(k,  43 ).EntireRow.ClearContents
                      End If
                    Next k
                    '*******

        Next iRow

Спасибо!
А то я до сих пор: как запущу весь код, начинаю считать минуты.
Так что пробую...

...

Рейтинг:

0 / 0

25.09.2007, 15:39:06

| Ответить | Цитировать | Написать

Автофильтр

#34825612

nPUBET

Гость

nPUBET.... то я до сих пор: как запущу весь код, начинаю считать минуты.
Так что пробую...

Код: plaintext

1.
2.
3.
4.

For k = konec To  1  Step - 1 
   If Not Cells( 1 , iPT) And Not Cells(k, iPT).Interior.ColorIndex =  4  Then '*****Error:13
   Cells(k, iPT).EntireRow.ClearContents
   End If
   Next k

хотел исключить первую строку, выводит ошибку 13.
Как исправить ошибку?

...

Рейтинг:

0 / 0

25.09.2007, 18:18:39

| Ответить | Цитировать | Написать

Автофильтр

#34825643

nPUBET

Гость

Код: plaintext

If Not fromRng.Cells( 1 , iPT) And Not Cells(k, iPT).Interior.ColorIndex =  4  Then

Так тоже не проходит...

...

Рейтинг:

0 / 0

25.09.2007, 18:28:12

| Ответить | Цитировать | Написать

Автофильтр

#34826470

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

Код: plaintext

For k = konec To  2  Step - 1

...

Рейтинг:

0 / 0

26.09.2007, 09:18:07

| Ответить | Цитировать | Написать

Автофильтр

#34829190

nPUBET

Гость

vkodor

Код: plaintext

For k = konec To  2  Step - 1

Спасибо! Исправил.

Подскажите, пожалуйста, как сформулировать описанный алгоритм?(файл приложил).

В листе =ucx= в приложенном файле строки, которые нужно удалить,
пометил различными цветами - для каждого номера с одинаковыми первыми 14 знаками - отдельный цвет.

Делаю так (на примере c =2AA10-C10001-A=):
1. Активирую лист =K1=, фильтрую по различным столбцам.

2. Иду в столбец =PCA=, чтобы определить размер проверки для номеров, в которых первые 14 знаков одинаковые. Для номеров c „2AA10-C10001-A“ - всего 12 строк.

3. Перехожу в столбец =No.=, ищу одинаковые числа по модулю (2967,03 = -2967,03;
1898,94 = -1898,94; 1253,82 = -1253,82; 17958,4 =-17958,4). Т.е. поиск идёт попарно.
В каждой паре должен обязательно присутствовать номер из =PCA= с 14 знаками,
а другой номер в этой паре должен содержать не менее 15 знаков.

4. Если для каждого номера с 14 знаками найдена пара (например,
-1=+1), тогда заканчиваю обработку для этого номера.
Пример записал в =Sub U_BET()= (второй модуль).
С функцией =ABS= всё отлично до тех пор, пока идёт сравнение верхней и нижней ячеек (соседних по вертикали). Однако нужные ячейки находятся не всегда по соседству - см. лист =K1=.

5. Найденные ячейки помечаю зеленным цветом. Всего 8 ячеек (для номера =2AA10-C10001-A=).

6. Если ячейка белого цвета, ничего не делаю, если ячейка помечена зелёным цветом - тогда удаляю всю строку.

Пока вот такой рабочий вариант.
Пометил ='***=, где остановился.

Код: plaintext

Sub OTRIC()
'************
Sheets("K1").Activate

    Dim i As Integer, fil As Filter, xlSh1 As Worksheet, rng As Range, rng2 As Range, rng3 As Range

    Set xlSh1 = ActiveSheet
    With xlSh1
        If .AutoFilterMode Then
            For Each fil In .AutoFilter.Filters
                If fil.On Then .ShowAllData: Exit For
            Next
        Else
            .Range(.Cells( 1 ,  1 ), .Cells( 1 , .UsedRange.Columns.Count +  1 )).AutoFilter '
        End If

        '************
        Dim iAB As Long
        Dim iPT As Long
        Dim iNo As Long


           iNo = .Range("1:1").Find("No*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

        iPT = .Range("1:1").Find("PC*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iPT, Criteria1:="*??????-A**", Operator:=xlOr, _
    Criteria2:="*??????-K**"

          iAB = .Range("1:1").Find("ABT*", LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
    .Range("a1").AutoFilter Field:=iAB, Criteria1:="T12"

       '******************* "=ABS(RC[-22])"
'
         .Range(.Cells( 2 ,  43 ), .Cells(.Cells(Rows.Count, iNo).End(xlUp).Row,  43 )).FormulaR1C1 = "=ABS(RC[" & iNo -  43  & "])"

         .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  43 ).End(xlUp).Row,  45 )).Sort Key1:=.Cells( 2 ,  43 ), _
        Order1:=xlAscending, Key2:=.Cells( 2 , iPT) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom


'************
'        Sub Udalenie()
        Columns("E:E").Interior.ColorIndex = xlNone
        Dim sK As String
        Dim iK As Long, jK As Long, kLong As Long, konec As Long
            Application.ScreenUpdating = False
            konec = Cells(Rows.Count,  43 ).End(xlUp).Row

Dim fromRng As Range
Dim iRow As Range
Dim kk As Long

Set fromRng = xlSh1.Range("2:" & .Cells(Rows.Count, iNo).End(xlUp).Row).SpecialCells(xlCellTypeVisible)

 kk = fromRng.Rows.Count
            For iK =  2  To kk
                For jK = iK +  1  To kk

                If Cells(iK, iPT) <> Cells(jK, iPT) And Left(Cells(iK, iPT).Value,  14 ) = Left(Cells(jK, iPT).Value,  14 ) _
                And Cells(iK,  43 ).Value = Cells(jK,  43 ).Value Then  '****** здесь остановился <=====

                    Cells(iK, iPT).Interior.ColorIndex =  4 
                    Cells(jK, iPT).Interior.ColorIndex =  4 
                            Else
                       End If

                Next jK
            Next iK
'******************************
   For k = konec To  2  Step - 1 

   If Not Cells(k, iPT).Interior.ColorIndex =  4  Then 
  Cells(k, iPT).EntireRow.ClearContents
  End If
  Next k
'                    *******
Range("Aq1").Value = "COPT"

      .Range(.Cells( 2 ,  1 ), .Cells(.Cells(Rows.Count,  43 ).End(xlUp).Row,  45 )).Sort Key1:=.Cells( 2 ,  43 ), _
        Order1:=xlAscending, Key2:=.Cells( 2 , iPT) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:= 1 , MatchCase:= _
        False, Orientation:=xlTopToBottom

'*********

    End With
End Sub

...

Рейтинг:

0 / 0

26.09.2007, 18:25:59

| Ответить | Цитировать | Написать

Автофильтр

#34831281

nPUBET

Гость

Здесь - часть алгоритма из верхнего поста.

Подскажите, пожалуйста, как определить динамически перемeнную
=номер строки c найденным значением в 43-ом столбце=.
Т.е вместо =номер строки c найденным значением в 43-ом столбце=
хотел бы вставить переменную типа Long . (Dim iStrok as Long).
Трудные участки пометил ='**1=, ='**2=.

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.

....
Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
''End Sub
'''************
''''Sub POISK()
    Dim rngB As Range
    Dim iB As Long, jB As Long
''''    Dim xlSh1 As Worksheet
''''
''''        Set xlSh1 = ActiveSheet
''''        With xlSh1
    
        iB =  1 
        Do While .Cells(iB, iNo).Value <> ""
            Set rngB = .Range("AQ:AQ").Find(What:=.Cells(iB,  43 ).Value,  _ 
After:=.Range("AQ1"), LookIn:=xlValues, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,  _ 
MatchCase:=True)
            If Not (rngB Is Nothing) Then
                jB = rngB.Row

'**********1
'If .Cells(iB, 43).Value =  _ 
.Cells("номер строки c найденным значением в 43-ом столбце", 43 ).Value And _               
'Left(Cells(iB, iPT).Value, 14) =  _ 
Left(Cells("номер строки c найденным значением в 43-ом столбце", iPT).Value,  14 )  And _
'.Cells(iB, iNo).Value >0 And _
'.Cells ("номер строки c найденным значением в 43-ом столбце", iNo) <0
'**********1
      
       Do

      '******2                           
       .Cells(iB,  10 ).Interior.ColorIndex =  37 
       .Cells("номер строки c найденным значением в 43-ом столбце", 10 ). _ 
Interior.ColorIndex =  37 
      '******2
                    
                    Set rngB = .Range("AQ:AQ").FindNext(rngB)
                Loop While jB <> rngB.Row
            End If
            End If
            iB = iB +  1 
        Loop
'''    End With
'''End Sub

    End With
End Sub

...

Рейтинг:

0 / 0

27.09.2007, 14:14:35

| Ответить | Цитировать | Написать

Автофильтр

#34832151

nPUBET

Гость

Oхватываю в листе =K1= примерно 60% нужных ячеек,
не выходя за пределы окрашенных ячеек, которые определил от руки в листе =ucx=
(см. файл в посте nPUBET, 26.09.2007, 18:25 ). Т.е. 60% ячеек нахожу без oшибок
(ненужные ячейки не обрабатываются).
Не получается сформулировать дополнительные условия
для полного охвата окрашенных ячеек, которые определил
вручную в листе =ucx=.

Подскажите, пожалуйста, как определить остаток -
40% нужных ячеек.

Код: plaintext

.....
End If
'End If
                Next jK
            Next iK
'******************************
'******************************
'   For k = konec To 2 Step -1
'
'   If Not Cells(k, iPT).Interior.ColorIndex = 4 Then
'  Cells(k, iPT).EntireRow.ClearContents
'  End If
'  Next k
''                    *******
Range("Aq1").Value = "COPT"
'
'      .Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 43).End(xlUp).Row, 45)).Sort Key1:=.Cells(2, 43), _
'        Order1:=xlAscending, Key2:=.Cells(2, iPT) _
'        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
'        False, Orientation:=xlTopToBottom
'
'*********
                        '''''Sub COPTUPOBKA_()
                                    Cells.Select
                                        Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
                                            OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom, _
                                            DataOption1:=xlSortNormal
                                        Range("A1").Select
''End Sub
'''************
'''Sub UBET()
    Columns("J:AS").Select
    Selection.Interior.ColorIndex = xlNone
    Range("j1").Select
'''End Sub
''''Sub POISK()
    Dim rngB As Range
    Dim iB As Long, jB As Long
''''    Dim xlSh1 As Worksheet
''''
''''        Set xlSh1 = ActiveSheet
''''        With xlSh1
    
        iB =  2 
        Do While .Cells(iB, iNo).Value <> ""
            Set rngB = .Range("AQ:AQ").Find(What:=.Cells(iB,  43 ).Value, After:=.Range("AQ2"), LookIn:=xlValues, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
            If Not (rngB Is Nothing) Then
                jB = rngB.Row
                If Cells(iB, iPT).Value <> Cells(jB, iPT).Value Then
                If Not Cells(iB,  10 ).Interior.ColorIndex =  37  And Not _
                        Cells(jB,  10 ).Interior.ColorIndex =  37  Then
                '********   <=====  дополнительные условия для полного охвата нужных ячеек

'                If Cells(iB, iNo).Value = Cells(jB, iNo).Value Then                
'                 If Left(Cells(iB, iPT).Value, 14) = Left(Cells(jB, iPT).Value, 14) And .Cells(iB, iNo).Value > 0 And _
'                 .Cells(jB, iNo).Value < 0 And Len(Cells(iB, iPT).Value) = 14 And Len(Cells(iB, iPT).Value) >= 15 _
'                   Then

                 ' And .Cells(iB, iPT).Value = .Cells(jB, iPT).Value
'                 If Left(Cells(iK, iPT).Value, 14) = Left(Cells(jB, iPT).Value, 14) And .Cells(iB, iNo).Value < 0 And _
       
                        Do
                    
                        Cells(iB,  10 ).Interior.ColorIndex =  37 
                        Cells(jB,  10 ).Interior.ColorIndex =  37 
                        
'                        Cells(iB, 43).Interior.ColorIndex = 37
'                       Cells(jB, 43).Interior.ColorIndex = 37

                    Set rngB = .Range("AQ:AQ").FindNext(rngB)
                Loop While jB <> rngB.Row  '*****
                    End If
                End If
            End If
            iB = iB +  1 
        Loop
'''    End With
'''End Sub

    End With
End Sub

...

Рейтинг:

0 / 0

27.09.2007, 17:02:18

| Ответить | Цитировать | Написать

Автофильтр

#34832772

nPUBET

Гость

Код: plaintext

.....
End If
'End If
                Next jK
            Next iK
'******************************
'******************************
'   For k = konec To 2 Step -1
'
'   If Not Cells(k, iPT).Interior.ColorIndex = 4 Then
'  Cells(k, iPT).EntireRow.ClearContents
'  End If
'  Next k
''                    *******
Range("Aq1").Value = "COPT"
'
'      .Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 43).End(xlUp).Row, 45)).Sort Key1:=.Cells(2, 43), _
'        Order1:=xlAscending, Key2:=.Cells(2, iPT) _
'        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
'        False, Orientation:=xlTopToBottom
'
'*********
                        '''''Sub COPTUPOBKA_()
                                    Cells.Select
                                        Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
                                            OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom, _
                                            DataOption1:=xlSortNormal
                                        Range("A1").Select
''End Sub
'''************
'''Sub UBET()
    Columns("J:AS").Select
    Selection.Interior.ColorIndex = xlNone
    Range("j1").Select
'''End Sub
''''Sub POISK()
    Dim rngB As Range
    Dim iB As Long, jB As Long
''''    Dim xlSh1 As Worksheet
''''
''''        Set xlSh1 = ActiveSheet
''''        With xlSh1
    
        iB =  2 
        Do While .Cells(iB, iNo).Value <> ""
            Set rngB = .Range("AQ:AQ").Find(What:=.Cells(iB,  43 ).Value, After:=.Range("AQ2"), LookIn:=xlValues, LookAt:= _
                xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
            If Not (rngB Is Nothing) Then
                jB = rngB.Row
                If Cells(iB, iPT).Value <> Cells(jB, iPT).Value Then
                If Not Cells(iB,  10 ).Interior.ColorIndex =  37  And Not _
                        Cells(jB,  10 ).Interior.ColorIndex =  37  Then
                '********   <=====  дополнительные условия для полного охвата нужных ячеек

'                If Cells(iB, iNo).Value = Cells(jB, iNo).Value Then                
'                 If Left(Cells(iB, iPT).Value, 14) = Left(Cells(jB, iPT).Value, 14) And .Cells(iB, iNo).Value > 0 And _
'                 .Cells(jB, iNo).Value < 0 And Len(Cells(iB, iPT).Value) = 14 And Len(Cells(iB, iPT).Value) >= 15 _
'                   Then

                 ' And .Cells(iB, iPT).Value = .Cells(jB, iPT).Value
'                 If Left(Cells(iK, iPT).Value, 14) = Left(Cells(jB, iPT).Value, 14) And .Cells(iB, iNo).Value < 0 And _
       
                        Do
                    
                        Cells(iB,  10 ).Interior.ColorIndex =  37 
                        Cells(jB,  10 ).Interior.ColorIndex =  37 
                        
'                        Cells(iB, 43).Interior.ColorIndex = 37
'                       Cells(jB, 43).Interior.ColorIndex = 37

                    Set rngB = .Range("AQ:AQ").FindNext(rngB)
                Loop While jB <> rngB.Row  '*****
                    End If
                End If
            End If
            iB = iB +  1 
        Loop
'''    End With
'''End Sub

    End With
End Sub

...

Рейтинг:

0 / 0

27.09.2007, 20:10:35

| Ответить | Цитировать | Написать

Автофильтр

#34834404

nPUBET

Гость

С этим алгоритмом ищутся все значения (одинаковые в абсолютном выражении) в 9-ом столбце, найденные строки помечаются в 11-ом столбце синим цветом. Т.е. здесь у меня перебор - 160% (охватываются все нужные ячейки и ненужные).

Пытаюсь построить следующее:
1. Ищу в 9-ом столбце противоположные по знаку, но одинаковые в абсолюте значения (например, 2967,03=-2967,03).
2. Если нахожу подходящие, то проверяю найденную пару на условия:
- в сумме пара равна нулю;
- проверка по данным из 5-ого столбца: здесь номер одного числа в паре имеет только 14 знаков, а номер другого числа в паре имеет более 15 знаков; первые 14 знаков номеров пары найденных чисел одинаковые.
3. Если условия пункта 2 выполняются, помечаю строки обоих чисел пары в 11-ом столбце синим цветом.

Подскажите, пожалуйста, что нужно изменить в =Sub Gde()=, чтобы находились правильные пары чисел (файл приложил).

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.

Sub Gde()
Sheets("K1").Activate
Columns("K:AS").Interior.ColorIndex = xlNone

   Dim rng As Range
   Dim iRow As Long
   Dim jB As Long
   iRow =  2 
   Do Until IsEmpty(Cells(iRow,  9 ))
      Set rng = ActiveSheet.Columns( 9 ).Find( _
         what:=-Cells(iRow,  9 ), lookat:=xlWhole, LookIn:=xlValues)
      If Not rng Is Nothing Then
      jB = rng.Row
'      If Not Cells(iRow, 11).Interior.ColorIndex = 37 Then
      '**************
'      If Left(Cells(iRow, 5).Value, 14) = Left(Cells(jB, 5).Value, 14) _
       Then
'      If Len(Cells(iRow, 5).Value) = 14 And Len(Cells(jB, 5).Value) > 14 _
      Then
      '**************
'      And .Cells(iB, 9).Value > 0 And .Cells(jB, 9).Value < 0

       Cells(iRow,  11 ).Interior.ColorIndex =  37 
'                End If
'            End If
      End If
      iRow = iRow +  1 
   Loop
End Sub

...

Рейтинг:

0 / 0

28.09.2007, 13:11:22

| Ответить | Цитировать | Написать

Автофильтр

#34835808

nPUBET

Гость

В этом файле код из последнего поста вообще ничего не находит. Ошибки не выводит.

Пытаюсь построить следующее:
1. Ищу в 9-ом столбце противоположные по знаку, но одинаковые в абсолюте значения (например, 348 = -348).

2. Если нахожу подходящие, то проверяю найденную пару на условия:
- в сумме пара равна нулю;
- проверка по данным из 5-ого столбца:
здесь номер одного числа в паре имеет только 14 знаков, а номер другого числа в паре имеет более 15 знаков;
первые 14 знаков номеров пары найденных чисел одинаковые.

3. Если условия пункта 2 выполняются, помечаю строки обоих чисел пары в 11-ом столбце синим цветом
( чтобы потом эти строки очистить при помощи =ClearContents= ).

Подскажите, пожалуйста, как сделать, чтобы строки с нужными парами чисел помечались цветом в 11-ом столбце.( файл приложил).

...

Рейтинг:

0 / 0

28.09.2007, 18:37:12

| Ответить | Цитировать | Написать

Автофильтр

#34837825

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.

Sub OTRIC()

    Dim xlSh1 As Worksheet, rngD As Range
    Dim iAB As Long, iPT As Long, iNo As Long, iRowD As Long, jD As Long

    Set xlSh1 = ActiveSheet
    With xlSh1


        iNo = .Range("1:1").Find("No*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
        
        iPT = .Range("1:1").Find("PC*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column
        
        iAB = .Range("1:1").Find("ABT*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

        .Columns("J:AS").Interior.ColorIndex = xlNone

        iRowD =  2 
   
        Do Until IsEmpty(.Cells(iRowD, iNo))
            If Len(.Cells(iRowD, iPT).Value) =  14  Then ' нет смысла осуществлять поиск если не выполняется это условие
                'начинаем поиск со строки 2, и т.к. число может быть отформатировано по разному надо искать в формулах (LookIn:=xlFormulas)
                Set rngD = .Columns( 9 ).Find(What:=-.Cells(iRowD, iNo), After:=.Cells( 2 , iNo), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False)
                If Not rngD Is Nothing Then
                    jD = rngD.Row
                    Do
                        'т.к. метод find ищет во всех строках а не только в xlCellTypeVisible, _
                            следовательно условие д.б. таким
                        If Len(.Cells(rngD.Row, iPT)) >=  15  And .Cells(rngD.Row, iAB) = "T12" And _
                            (.Cells(rngD.Row, iPT) Like "*??????-A**" Or .Cells(rngD.Row, iPT) Like "*??????-K**") Then
                                .Cells(iRowD,  11 ).Interior.ColorIndex =  37 
                                .Cells(jD,  11 ).Interior.ColorIndex =  37 
                                Exit Do 'если условие выполнено выходим из цикла (нет смысла искать дальше)
                        Else
                            'если условие не выполняется нодо искать дальше
                            Set rngD = .Columns( 9 ).FindNext(rngD)
                        End If
                    Loop While rngD.Row <> jD ' поиск осуществлять пока найденая строка не равна строке первого найденого значения
                End If
            End If
            iRowD = iRowD +  1 
        Loop
    End With
End Sub

P.S. Хорошое у тебя упорство.

...

Рейтинг:

0 / 0

01.10.2007, 11:26:29

| Ответить | Цитировать | Написать

Автофильтр

#34838155

nPUBET

Гость

vkodor
Большое спасибо!
Без учебников (в физической форме) немного трудновато сочинять на VBA.

...пытаюсь улучшить Твой код:
у меня в 9-ом столбце (No.) часто повторяются пары (см. рисунок).
Т.е первую пару алгоритм выделяет, а вот, если клоны, то код их не помечает (пытаюсь сделать, чтобы помечались и другие одинаковые пары).

P.S. клоны - одинаковые пары, например, для Len=14 и Len>=15 пара 1899= -1899 может повторятся несколько раз для одного и того же номера с одинаковыми первыми 14 знаками из 5-го столбца.
На риc. - в 3-х ячейках стоят серые точки. Вот эти ячейки с серыми точками не заполняются синим цветом (пытаюсь их заполнить).

...

Рейтинг:

0 / 0

01.10.2007, 13:06:18

| Ответить | Цитировать | Написать

Автофильтр

#34838160

nPUBET

Гость

Вот файл

...

Рейтинг:

0 / 0

01.10.2007, 13:07:39

| Ответить | Цитировать | Написать

Автофильтр

#34838192

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

вместо строки

Код: plaintext

Exit Do 'если условие выполнено выходим из цикла (нет смысла искать дальше)

поставь

Код: plaintext

Set rngD = .Columns( 9 ).FindNext(rngD)

а лучше так

Код: plaintext

1.
2.
3.
4.
5.

                        If Len(.Cells(rngD.Row, iPT)) >=  15  And .Cells(rngD.Row, iAB) = "T12" And _
                            (.Cells(rngD.Row, iPT) Like "*??????-A**" Or .Cells(rngD.Row, iPT) Like "*??????-K**") Then
                                .Cells(iRowD,  11 ).Interior.ColorIndex =  37 
                                .Cells(jD,  11 ).Interior.ColorIndex =  37 
                        End If
                        Set rngD = .Columns( 9 ).FindNext(rngD) ' ищем дальше

...

Рейтинг:

0 / 0

01.10.2007, 13:19:13

| Ответить | Цитировать | Написать

Автофильтр

#34838285

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

да и замени

Код: plaintext

.Columns( 9 ).

на

Код: plaintext

.Columns(iNo).

...

Рейтинг:

0 / 0

01.10.2007, 13:41:57

| Ответить | Цитировать | Написать

Автофильтр

#34838352

nPUBET

Гость

vkodorвместо строки

Код: plaintext

Exit Do 'если условие выполнено выходим из цикла (нет смысла искать дальше)

поставь

Код: plaintext

Set rngD = .Columns( 9 ).FindNext(rngD)

а лучше так

Код: plaintext

1.
2.

                        If Len(.Cells(rngD.Row, iPT)) >=  15 ....
                        End If
                        Set rngD = .Columns( 9 ).FindNext(rngD) ' ищем дальше

Изменил на так:

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.

      ....Do
 If Len(.Cells(rngD.Row, iPT)) >=  15  And .Cells(rngD.Row, iAB) = "T12" And _
   (.Cells(rngD.Row, iPT) Like "*??????-A**" Or .Cells(rngD.Row, iPT) Like "*??????-K**") Then
    .Cells(iRowD,  11 ).Interior.ColorIndex =  37 
    .Cells(jD,  11 ).Interior.ColorIndex =  37 
      End If
     Set rngD = .Columns( 9 ).FindNext(rngD)
     Else
   End If
   Loop While rngD.Row <> jD '
  End If
'  ' End If 
 '*********
  iRowD = iRowD +  1 
      Loop
    End With
End Sub

не выделяет...

может здесь возможно как-нибудь:

Код: plaintext

Loop While rngD.Row <> jD

...

Рейтинг:

0 / 0

01.10.2007, 13:56:27

| Ответить | Цитировать | Написать

Автофильтр

#34838361

nPUBET

Гость

vkodorда и замени

Код: plaintext

.Columns( 9 ).

на

Код: plaintext

.Columns(iNo).

заменил, не срабатывает...

...

Рейтинг:

0 / 0

01.10.2007, 13:58:44

| Ответить | Цитировать | Написать

Автофильтр

#34838426

vkodor

Участник

Откуда: Moscow

Сообщения: 1 809

Рейтинг: 0 / 0

в строке .Cells(rngD.Row, 11).Interior.ColorIndex = 37 - была ошибка (sorry)

Код: plaintext

1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.

Sub OTRIC()

    Dim xlSh1 As Worksheet, rngD As Range
    Dim iAB As Long, iPT As Long, iNo As Long, iRowD As Long, jD As Long

    Set xlSh1 = ActiveSheet
    With xlSh1


        iNo = .Range("1:1").Find("No*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

        iPT = .Range("1:1").Find("PC*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

        iAB = .Range("1:1").Find("ABT*", LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Column

        .Columns("J:AS").Interior.ColorIndex = xlNone

        iRowD =  2 

        Do Until IsEmpty(.Cells(iRowD, iNo))
            If Len(.Cells(iRowD, iPT).Value) =  14  Then ' нет смысла осуществлять поиск если не выполняется это условие
                'начинаем поиск со строки 2, и т.к. число может быть отформатировано по разному надо искать в формулах (LookIn:=xlFormulas)
                Set rngD = .Columns(iNo).Find(What:=-.Cells(iRowD, iNo), After:=.Cells( 2 , iNo), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False)
                If Not rngD Is Nothing Then
                    jD = rngD.Row
                    Do
                        'т.к. метод find ищет во всех строках а не только в xlCellTypeVisible, _
                            следовательно условие д.б. таким
                        If Len(.Cells(rngD.Row, iPT)) >=  15  And .Cells(rngD.Row, iAB) = "T12" And _
                            (.Cells(rngD.Row, iPT) Like "*??????-A**" Or .Cells(rngD.Row, iPT) Like "*??????-K**") Then
                                .Cells(iRowD,  11 ).Interior.ColorIndex =  37 
                                .Cells(rngD.Row,  11 ).Interior.ColorIndex =  37  
                        End If
                        Set rngD = .Columns(iNo).FindNext(rngD) 'ищем дальше
                    Loop While rngD.Row <> jD ' поиск осуществлять пока найденая строка не равна строке первого найденого значения
                End If
            End If
            iRowD = iRowD +  1 
        Loop
    End With
End Sub

...

Рейтинг:

0 / 0

01.10.2007, 14:17:09

| Ответить | Цитировать | Написать

Автофильтр

#34838481

nPUBET

Гость

vkodorв строке .Cells(rngD.Row, 11).Interior.ColorIndex = 37 - была ошибка (sorry)

Код: plaintext

1.
2.
3.

Sub OTRIC()
...        Loop
    End With
End Sub

Спасибо!
Выделяет...

...

Рейтинг:

0 / 0

01.10.2007, 14:29:59

| Ответить | Цитировать | Написать

51 сообщений из 51, показаны все 3 страниц

все

Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Автофильтр

Читали тему (0):

Читали форум (0):

Пользователи онлайн (0):

start [/forum/topic.php?all=1&fid=61&tid=2182184]:	0ms
get settings:	5ms
get forum list:	9ms
check forum access:	2ms
check topic access:	2ms
track hit:	28ms
get topic data:	6ms
get forum data:	1ms
get page messages:	44ms
get tp. blocked users:	1ms
others:	180ms

total:	278ms

	Необходимые cookie
	Cookie для сбора статистики
	Cookie для маркетинга и рекламы