powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Автофильтр
25 сообщений из 51, страница 2 из 3
Автофильтр
    #34818277
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
vkodor nPUBET
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?
Конечно можно, и это у тебя уже было.
Код: plaintext
1.
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
Автофильтр
    #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
Автофильтр
    #34819084
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
...
Рейтинг: 0 / 0
Автофильтр
    #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
Автофильтр
    #34824554
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
Автофильтр
    #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
Автофильтр
    #34824893
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
nPUBET vkodor nPUBET
Mожет это возможно как-то через Cells.SpecialCells(xlCellTypeVisible)?
Конечно можно, и это у тебя уже было.
Код: plaintext
1.
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-ом столбце одинаковые, только тогда удаляю эти строки. А скрытые строки не трогаю

попробуй так
Код: 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
Автофильтр
    #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
Автофильтр
    #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
Автофильтр
    #34825643
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Код: plaintext
If Not fromRng.Cells( 1 , iPT) And Not Cells(k, iPT).Interior.ColorIndex =  4  Then
Так тоже не проходит...
...
Рейтинг: 0 / 0
Автофильтр
    #34826470
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Код: plaintext
For k = konec To  2  Step - 1 
...
Рейтинг: 0 / 0
Автофильтр
    #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
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.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
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
Автофильтр
    #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
Автофильтр
    #34832151
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Oхватываю в листе =K1= примерно 60% нужных ячеек,
не выходя за пределы окрашенных ячеек, которые определил от руки в листе =ucx=
(см. файл в посте nPUBET, 26.09.2007, 18:25 ). Т.е. 60% ячеек нахожу без oшибок
(ненужные ячейки не обрабатываются).
Не получается сформулировать дополнительные условия
для полного охвата окрашенных ячеек, которые определил
вручную в листе =ucx=.

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


Код: 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.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
.....
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
Автофильтр
    #34832772
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Oхватываю в листе =K1= примерно 60% нужных ячеек,
не выходя за пределы окрашенных ячеек, которые определил от руки в листе =ucx=
(см. файл в посте nPUBET, 26.09.2007, 18:25 ). Т.е. 60% ячеек нахожу без oшибок
(ненужные ячейки не обрабатываются).
Не получается сформулировать дополнительные условия
для полного охвата окрашенных ячеек, которые определил
вручную в листе =ucx=.

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


Код: 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.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
.....
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
Автофильтр
    #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
Автофильтр
    #34835808
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
В этом файле код из последнего поста вообще ничего не находит. Ошибки не выводит.

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

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

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

Подскажите, пожалуйста, как сделать, чтобы строки с нужными парами чисел помечались цветом в 11-ом столбце.( файл приложил).
...
Рейтинг: 0 / 0
Автофильтр
    #34837825
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.
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
Автофильтр
    #34838155
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
vkodor
Большое спасибо!
Без учебников (в физической форме) немного трудновато сочинять на VBA.

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

P.S. клоны - одинаковые пары, например, для Len=14 и Len>=15 пара 1899= -1899 может повторятся несколько раз для одного и того же номера с одинаковыми первыми 14 знаками из 5-го столбца.
На риc. - в 3-х ячейках стоят серые точки. Вот эти ячейки с серыми точками не заполняются синим цветом (пытаюсь их заполнить).
...
Рейтинг: 0 / 0
Автофильтр
    #34838160
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Вот файл
...
Рейтинг: 0 / 0
Автофильтр
    #34838192
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
вместо строки
Код: 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
Автофильтр
    #34838285
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
да и замени
Код: plaintext
.Columns( 9 ).
на
Код: plaintext
.Columns(iNo).
...
Рейтинг: 0 / 0
Автофильтр
    #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
Автофильтр
    #34838361
nPUBET
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
vkodorда и замени
Код: plaintext
.Columns( 9 ).
на
Код: plaintext
.Columns(iNo).

заменил, не срабатывает...
...
Рейтинг: 0 / 0
Автофильтр
    #34838426
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
в строке .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
25 сообщений из 51, страница 2 из 3
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Автофильтр
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]