Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 19.04.2018, 16:28   #1
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию Копирование строк по условию(выделенные цветом ячейки) на отдельный лист

Доброго всем времени суток!
Я токарь-станочник,в макросах профан,прошу помощи. Суть в следующем(пытаюсь создать учёт запчастей),нужно собрать на отдельном листе все строки содержащие красные ячейки по их условиям на всех других листах книги,типа отчёт на одном листе"Расходник". И чтобы при изменении условия(красное выделение ячейки) строка пропадала с листа "Расходник".
файлик прилагаю,за ранее спасибо!
Вложения
Тип файла: xlsx Тест_1.xlsx (39.6 Кб, 20 просмотров)

Последний раз редактировалось geo248; 19.04.2018 в 16:30.
geo248 вне форума Ответить с цитированием
Старый 19.04.2018, 16:43   #2
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

Цитата:
Сообщение от geo248 Посмотреть сообщение
Нужно собрать на отдельном листе все строки содержащие красные ячейки по их условиям
Вы забыли сказать, что красным ячейки заливаются с помощью "Условного форматирования". Условие заливки - "Значение ячейки < 2"
Т.о. Вам нужно собрать на лист "Расходник" все строчки, где в столбце D (Остатки) значение < 2
Так?

Теперь второе.
А когда на листе "Расходник" должны собираться строчки? В реал-тайм? Разве в этом есть смысл? Возможно, проще и удобнее сделать на листе "Расходник" кнопку - "Сформировать список" ?
Serge_Bliznykov вне форума Ответить с цитированием
Старый 20.04.2018, 07:31   #3
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию

Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
Условие заливки - "Значение ячейки < 2"
Т.о. Вам нужно собрать на лист "Расходник" все строчки, где в столбце D (Остатки) значение < 2
Так?

Теперь второе.
Возможно, проще и удобнее сделать на листе "Расходник" кнопку - "Сформировать список" ?
Всё так Сергей,значения в столбце D могут быть разными,зависит от условий(на этом листе это:<2,для подшипников),это правится вручную,зависит от потребностей.Это значение может быть разным для любой позиции на листе.
По поводу кнопки, я не задумывался,можно и так. Есть у меня "начальник",которому лень "переворачивать" листы и делать отчёт,имею головную боль.)

Последний раз редактировалось geo248; 20.04.2018 в 07:37.
geo248 вне форума Ответить с цитированием
Старый 20.04.2018, 09:49   #4
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

Цитата:
Сообщение от geo248 Посмотреть сообщение
это правится вручную,зависит от потребностей.
насколько я понимаю - это проблема. я лично не знаю, как в макросе проверить цвет ячейки, если он задан не ручками,а устанавливается через УФ.
Serge_Bliznykov вне форума Ответить с цитированием
Старый 20.04.2018, 12:02   #5
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию

Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
насколько я понимаю - это проблема. я лично не знаю, как в макросе проверить цвет ячейки, если он задан не ручками,а устанавливается через УФ.
С этим ясно,может тогда можно мне помочь,по значению в самой ячейке?
Буду уже выставлять эти значения ,пытаться,как-то одинаково или может быть возможно поставить диапазон значений(в меньшую сторону)? В VBA не силён,буду признателен.
geo248 вне форума Ответить с цитированием
Старый 20.04.2018, 12:41   #6
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию

А как скопировать со всех листов нужные строки?

Последний раз редактировалось geo248; 20.04.2018 в 16:23.
geo248 вне форума Ответить с цитированием
Старый 20.04.2018, 20:16   #7
Oldy7
Пользователь
 
Регистрация: 25.02.2012
Сообщений: 28
По умолчанию

Не совсем понятно нужно удалить строку откуда переносим данные после переноса этих данных, или нужно удалить/обнулить содержимое столбца "Расход" во всех листах?
Проверяется только на значение в ячейке с УФ меньше указанного в этой УФ, если по условиям УФ ячейка окрашивается красным.
Как выяснилось таким образом можно проверить только одно условие/правило для УФ.
Пробуйте (удаление закомментировано):
Код:
Sub test()
Dim aa As Range, sh As Worksheet, a%, oo As Object, b%, c%, zz, bb As Range, x&
x = Sheets("Расходник").[a1].CurrentRegion.Rows.Count + 1
If x = 2 Then x = 1
For Each sh In ThisWorkbook.Worksheets
  If sh.Name <> "Расходник" Then
    a = sh.[a1].CurrentRegion.Find(what:="Остат", LookIn:=xlValues, LookAt:=xlPart).Column
    For Each aa In Intersect(sh.[a1].CurrentRegion.EntireRow, sh.Columns(a))
      Set oo = aa.FormatConditions
      If oo.Count > 0 Then
        For c = 1 To oo.Count
          zz = oo.Item(c).Interior.Color
          b = CLng(Split(oo.Item(c).Formula1, "=")(1))
          If zz = vbRed Then
            If aa < b Then
              Set bb = Sheets("Расходник").Range(Sheets("Расходник").Cells(x, 1), Sheets("Расходник").Cells(x, a))
              Union(bb.Columns(2), bb.Columns(1)).NumberFormat = "@"
              bb.Value = sh.Range(sh.Cells(aa.Row, 1), sh.Cells(aa.Row, a)).Value
              bb.Borders.LineStyle = xlContinuous
              Intersect(bb, Columns(1)) = sh.Name
              'aa.Offset(, 1) = Empty' обнуляет содержимое последнего столбца
              x = x + 1
            End If
          End If
        Next
      End If
    Next
  End If
Next
End Sub

Последний раз редактировалось Oldy7; 20.04.2018 в 20:39.
Oldy7 вне форума Ответить с цитированием
Старый 21.04.2018, 09:52   #8
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию

Цитата:
Сообщение от Oldy7 Посмотреть сообщение
Не совсем понятно нужно удалить строку откуда переносим данные после переноса этих данных, или нужно удалить/обнулить содержимое столбца "Расход" во всех листах?
Проверяется только на значение в ячейке с УФ меньше указанного в этой УФ, если по условиям УФ ячейка окрашивается красным.
Как выяснилось таким образом можно проверить только одно условие/правило для УФ.
Доброго дня Oldy7,по сути ничего удалять не надо,в идеале нужно,чтобы ячейки с УФ (красным),на любом листе, копировались на лист "Расходник",а когда условие становится фальш, с листа "Расходник" эта строка строка исчезала. Т.е. поступили новые запчасти к примеру, одни добавились на свои листы, УФ изменилось и значение стало больше ,чем в УФ(цвет ячейки снова стал белым).
Своего рода лист "Расходник" заявка на покупку позиций,которых мало или нет совсем.

Пробу.,обидно,не знаю операторов VBA, вроде бы,то что надо!
Спасибо за уделённое время.
Попробую поиграться ещё )))

Последний раз редактировалось geo248; 21.04.2018 в 11:16.
geo248 вне форума Ответить с цитированием
Старый 21.04.2018, 12:08   #9
geo248
 
Регистрация: 19.04.2018
Сообщений: 9
По умолчанию

Всё работает ,только ещё один моментик,последний колонку выводить не нужно,только "Остаток",подскажите,что убрать в коде?
geo248 вне форума Ответить с цитированием
Старый 21.04.2018, 12:46   #10
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

я так красиво, как Oldy7, писать код не умею.

поэтому сотворил такого вот кривенького-уродца:
Тест_3-xlsm.zip

код там такой:
Код:
Private Sub Worksheet_Activate()
  Dim sSheetName As String, iRow As Long, iLastrow As Long, i As Long
  Dim wsSh As Object, wsDataSheet As Object, wsAct As Object
  Dim wbAct As Workbook, Rng As Range
  
  ' переменные для циклов по ячейкам с условным форматированием
    Dim CC, FF As Range
    Dim Ndx As Long, filterValue As Long
    Dim FC As FormatCondition
    Dim Temp As Variant
    Dim Temp2 As Variant
    Dim valstr As String
    Dim output As String
  

  If MsgBox("Обновить таблицу и собрать новые данные с других листов?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
    Set wbAct = ThisWorkbook
    Set wsAct = wbAct.ActiveSheet

    ' очистить содержимое листа
    wsAct.Cells.Clear
    
    'скопируем заголовок на лист с отчётом
    Set Rng = wbAct.Worksheets(1).Range("A1:E3")
    Rng.Copy
    wsAct.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
    wsAct.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
    wsAct.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    
    iRow = 4
    'цикл по листам
    For Each wsSh In wbAct.Sheets
        If (wsSh.Name <> wsAct.Name) And (wsSh.Visible = xlSheetVisible) Then
          wsAct.Cells(iRow, 2) = wsSh.Name ' выведем название листа
          
          ' оформим красиво заголовок
          With wsAct.Range("A" & iRow & ":E" & iRow)
           .Interior.Color = 15773696
           .Font.Name = "Calibri"
           .Font.Size = 16
          End With
          iRow = iRow + 1
          
          'цикл по данным на листе и копирование нужных данных на результирующий лист
          iLastrow = wsSh.Cells(wsSh.Rows.Count, "A").End(xlUp).Row
          
          If iLastrow > 3 Then
            Set Rng = wsSh.Range("D4:D" & iLastrow)
            For Each CC In Rng
              If Not IsEmpty(CC) And (CC.FormatConditions.Count > 0) Then
                For Ndx = 1 To CC.FormatConditions.Count
                    Set FC = CC.FormatConditions(Ndx)  'CC.FormatConditions.Item(Ndx)
                    If FC.Type = xlCellValue Then
                        filterValue = CInt(Mid(FC.Formula1, 2))
                        If Not IsEmpty(CC.Offset(0, -2)) And _
                          ((FC.Operator = 6) And (CC.Value < filterValue) _
                            Or _
                           (FC.Operator = 8) And (CC.Value <= filterValue)) Then
                          wsSh.Range(CC.Offset(0, -3).Address & ":" & CC.Offset(0, 1).Address).Copy
                          wsAct.Cells(iRow, 1).PasteSpecial Paste:=xlPasteValues
                          iRow = iRow + 1
                        End If
                    End If
                Next Ndx
              End If
            Next CC
          End If
        End If
    Next wsSh
    
  End If
End Sub
Serge_Bliznykov вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поиск и копирование строк, как найти все строки по 3-м одинаковым значениям и скопировать их на отдельный лист? stasdi Microsoft Office Excel 7 13.04.2018 14:03
Копирование строк из нескольких Листов по условию на Лист это же Книги Mutarix Microsoft Office Excel 1 24.11.2014 17:30
Копирование строк таблицы по условию одной ячейки из Лист 1 в Лист 2 Людвиг Microsoft Office Excel 5 25.10.2014 11:46
копирование строк, соответствующих условию фильтра и копирование на новый лист xorek Microsoft Office Excel 0 09.07.2012 18:13
Поиск по выделенным красным цветом строк и копирование их на новый лист. PetroD Microsoft Office Excel 11 10.08.2010 15:01