Страницы: 1
RSS
Отбор данных из таблицы по количеству замечаний
 
Добрый вечер, всем участникам! У меня в очередной раз очень серьезный и сложный вопрос. На мой взгляд :D Думаю для Вас не очень.
Постараюсь объяснить суть проблемы, вопроса. Есть таблица с перечнем замечаний (не важно чего) в которой фиксируются все замечания полученные каждый день. И есть справка по количеству полученных и т.д. по этим замечаниям информации. Вот мне интересно, а можно ли сделать так, чтобы при двойном (или тройном, или еще как то) по ячейке появлялся лист со сборкой той информации в которой посчитана в справке по данному человеку. В прикладываемом файле два листа. В одном из них справка. В справке я выделил столбцы в которых и требуется данная информация.
спасибо всем кто поможет разобраться. Да и вообще всем.
 
Более подробно опишите задачу, иначе не получите ответа правильного. Конкретно куда ткнуть и что должно собраться.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.
 
Добрый день. Прошу прощения за поздний ответ. Попал на больничный. Видимо из-за переживаний :D
Сейчас попробую по другому сформулировать задачу.
Вот на примере сотрудника Дудников И.В. в приложенной справке есть информация о том что он за этот период (указанный в справке) получил 3 замечания. При нажатии на количество замечаний в справке (я выделил кружком), результат должен появится на другом листе. И так по любому сотруднику из списка, из столбцов выделенных желтым цветом. Список соответственно бывает очень большим.
Надеюсь сейчас стала более понятно.
Еще раз прошу простить за такую паузу.
Спасибо
 
Tamagafk,  в модуль листа "Справка 3в1"
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 3 Then Exit Sub

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Worksheets("Замечания"): Set sh2 = Worksheets("Справка 3в1"): Set sh3 = Worksheets("Результат")
sh3.Range("A3:F1000").ClearContents
FIO = Target.Offset(0, -1)
k = 3
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To lr

    If sh1.Cells(i, 8) = FIO Then
    sh3.Cells(k, 1) = sh1.Cells(i, 1)
    sh3.Cells(k, 2) = sh1.Cells(i, 2)
    sh3.Cells(k, 3) = sh1.Cells(i, 3)
    sh3.Cells(k, 4) = sh1.Cells(i, 4)
    sh3.Cells(k, 5) = sh1.Cells(i, 5)
    sh3.Cells(k, 6) = sh1.Cells(i, 8)
    k = k + 1
    End If
    
Next i
End Sub



Не бойтесь совершенства. Вам его не достичь.
 
Mershik, день добрый, что я не так делаю? у меня не работает. Добавил к модулю листа, и ничего...
Можно на примере?
Спасибо
 
Цитата
Tamagafk написал:
Можно на примере?
а можно Ваш пример увидеть с макросом?
пока прикрепляете файл о модулях -  https://www.excel-vba.ru/chto-umeet-excel/chto-takoe-modul-kakie-byvayut-moduli/
Изменено: Mershik - 18.09.2020 15:16:32
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, спасибо эта ссылка очень помогла. Работает, но от части. Отбор идет всех замечаний по фамилии, а не по дате которая указана в справке.
Изначально я писал, что отбор должен быть по количеству указанному в период этих дат.
 
Tamagafk, ну добавите условия (даже не понятно дата чего)
так как вы объясняете задачу так и получаете ответ)
предположу что дата столбца D
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 3 Then Exit Sub
 
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Worksheets("Çàìå÷àíèÿ"): Set sh2 = Worksheets("Ñïðàâêà 3â1"): Set sh3 = Worksheets("Ðåçóëüòàò")
sh3.Range("A3:F1000").ClearContents
FIO = Target.Offset(0, -1)
k = 3
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To lr
 
    If sh1.Cells(i, 8) = FIO Then
    If sh1.Cells(i, 4) >= sh2.Cells(2, 1) And sh1.Cells(i, 4) <= sh2.Cells(2, 2) Then
        sh3.Cells(k, 1) = sh1.Cells(i, 1)
        sh3.Cells(k, 2) = sh1.Cells(i, 2)
        sh3.Cells(k, 3) = sh1.Cells(i, 3)
        sh3.Cells(k, 4) = sh1.Cells(i, 4)
        sh3.Cells(k, 5) = sh1.Cells(i, 5)
        sh3.Cells(k, 6) = sh1.Cells(i, 8)
        k = k + 1
    End If
    End If
     
Next i
End Sub

удачи.
Изменено: Mershik - 21.09.2020 09:31:22
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, не знаю даже как выразить словами, благодарность. Спасибо, именно то что надо. Но...))) Как применить данное действие ко всем остальным столбцам? Во вложении выделил кружком те столбцы где это необходимо. Спасибо за ранее.
 
Tamagafk, не понял, нужно что бы этот же макрос делал тоже самое только когда двойной клик и в других столбцах?
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim arr
arr = Array(3, 7, 11, 15, 19, 23, 27, 31)
k = 0
For i = LBound(arr) To UBound(arr)
If Target.Column = arr(i) Then k = k + 1
Next i
If k = 0 Then Exit Sub
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Worksheets("Замечания"): Set sh2 = Worksheets("Справка 3в1"): Set sh3 = Worksheets("Результат")
sh3.Range("A3:F1000").ClearContents
FIO = Cells(Target.Row, 2)
k = 3
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To lr
    If sh1.Cells(i, 8) = FIO Then
    If sh1.Cells(i, 4) >= sh2.Cells(2, 1) And sh1.Cells(i, 4) <= sh2.Cells(2, 2) Then
        sh3.Cells(k, 1) = sh1.Cells(i, 1)
        sh3.Cells(k, 2) = sh1.Cells(i, 2)
        sh3.Cells(k, 3) = sh1.Cells(i, 3)
        sh3.Cells(k, 4) = sh1.Cells(i, 4)
        sh3.Cells(k, 5) = sh1.Cells(i, 5)
        sh3.Cells(k, 6) = sh1.Cells(i, 8)
        k = k + 1
    End If
    End If
Next i
End Sub
Изменено: Mershik - 23.09.2020 14:27:15
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, да Вы правильно поняли. Но отбор столбцов из листа "Замечания" должен быть разным
 
Tamagafk, ну переделаете как вам нужно, укажите что нужно я гадать не буду. удачи.
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, добрый день. Прошу простить, у меня не получается. Попробую пояснить подробно.
На примере Дудникова. Из "Получено" в период с 31.08.2020 по 06.09.2020 по данному сотруднику 3 замечания. Период дат берется из столбца D листа "Замечания".
Из "Получено (красная линия)" в период с 31.08.2020 по 06.09.2020 по данному сотруднику 1 замечание. Так как есть дополнительный столбец I на листе "Замечания", "Красная линия". Период дат также из столбца D.
Из "Устранено" по нему 2 замечания. Здесь период дат должен браться из столбца F. И также по "Устранено (красная линия)", дополнительный столбец I.
И из "Всего в работе", из столбца F "пустые значения". По данному сотруднику 1 замечание. И Аналогично "Всего в работе (красная линия)" дополнительный столбец I.
Пожалуйста помогите.
 
Tamagafk, дд. наверное как-то так - возможно можно короче...
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Worksheets("Замечания"): Set sh2 = Worksheets("Справка 3в1"): Set sh3 = Worksheets("Результат")
sh3.Range("A3:F1000").ClearContents
FIO = Cells(Target.Row, 2)
k = 3
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To lr
If Target.Column = 3 Then ' ПОЛУЧЕНО
    If sh1.Cells(i, 8) = FIO Then
        If sh1.Cells(i, 4) >= sh2.Cells(2, 1) And sh1.Cells(i, 4) <= sh2.Cells(2, 2) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8)
                k = k + 1
        End If
    End If
ElseIf Target.Column = 7 Then ' Получено (красная линия):
    If sh1.Cells(i, 8) = FIO And sh1.Cells(i, 9) = "входит" Then
        If sh1.Cells(i, 4) >= sh2.Cells(2, 1) And sh1.Cells(i, 4) <= sh2.Cells(2, 2) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8)
            k = k + 1
        End If
    End If
ElseIf Target.Column = 11 Then ' УСТРАНЕНО
    If sh1.Cells(i, 8) = FIO Then
        If sh1.Cells(i, 6) >= sh2.Cells(2, 1) And sh1.Cells(i, 6) <= sh2.Cells(2, 2) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8):
            k = k + 1
        End If
    End If
ElseIf Target.Column = 15 Then ' Устранено (красная линия):
    If sh1.Cells(i, 8) = FIO And sh1.Cells(i, 9) = "входит" Then
        If sh1.Cells(i, 6) >= sh2.Cells(2, 1) And sh1.Cells(i, 6) <= sh2.Cells(2, 2) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8)
            k = k + 1
        End If
    End If
ElseIf Target.Column = 19 Then ' Всего в работе
    If sh1.Cells(i, 8) = FIO Then
        If IsEmpty(sh1.Cells(i, 6)) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8)
            k = k + 1
        End If
    End If
ElseIf Target.Column = 23 Then ' Всего в работе (красная линия):
    If sh1.Cells(i, 8) = FIO And sh1.Cells(i, 9) = "входит" Then
        If IsEmpty(sh1.Cells(i, 6)) Then
            sh3.Cells(k, 1) = sh1.Cells(i, 1): sh3.Cells(k, 2) = sh1.Cells(i, 2): sh3.Cells(k, 3) = sh1.Cells(i, 3)
            sh3.Cells(k, 4) = sh1.Cells(i, 4): sh3.Cells(k, 5) = sh1.Cells(i, 5): sh3.Cells(k, 6) = sh1.Cells(i, 8)
            k = k + 1
        End If
    End If
End If
Next i
End Sub
Изменено: Mershik - 28.09.2020 09:57:43
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, спасибо Вам огромное! Это то что надо!
Страницы: 1
Наверх