Страницы: 1
RSS
Вытащить данные по нескольким критериям, Подскажите пожалуйста решение, нужно вытащить данные по нескольким критериям и вставить их в табличку один за другим.
 
Подскажите пожалуйста решение, нужно вытащить данные по нескольким критериям и вставить их в табличку один за другим. При том что для отдельных параметров есть отдельные таблички. Короткий пример вложил.
 
Подобные задачи достаточно несложно решаются макросом.
Если такое решение вам подходит, то надо быть готовым к тому, что в коде в любом случае придется разбираться и доводить его до ума.
Код
Sub Оценка()

    Dim СтрокаОтчет As Long
    Dim СтрокаОценка As Long
    Dim СтолбецОтчет As Integer
    
    Dim ЛистОтчет As Worksheet
    Dim ЛистОценок As Worksheet
    
    Dim НайденаДолжность As Boolean
    Dim НайденаОценка As Boolean
    
    Set ЛистОтчет = Worksheets("ППР_КПЭ_5+")
    СтрокаОтчет = 4 'Данные в отчетном листе заполняются начиная с 4 строки
    
    'Очистка заполненных данных в листах с оценками
    For Each ЛистОценок In ThisWorkbook.Worksheets
        If ЛистОценок.Name <> "ППР_КПЭ_5+" Then
            Range(ЛистОценок.Rows("5:5"), ЛистОценок.Rows("5:5").End(xlDown)).ClearContents
        End If
    Next
    
    Do Until ЛистОтчет.Cells(СтрокаОтчет, 5) = ""
            НайденаДолжность = True
        Select Case ЛистОтчет.Cells(СтрокаОтчет, 5)
            Case "2"
                Set ЛистОценок = Worksheets("Директора ССП")
            Case "3"
                Set ЛистОценок = Worksheets("Зам Директора ССП")
            Case "2.1"
                Set ЛистОценок = Worksheets("Директора Филиалов")
            Case "3.1"
                Set ЛистОценок = Worksheets("Зам Директора Филиала")
            Case Else
                НайденаДолжность = False
            End Select
            If НайденаДолжность = True Then
                    НайденаОценка = True
                Select Case ЛистОтчет.Cells(СтрокаОтчет, 9)
                    Case "B", "В"
                        СтолбецОтчет = 1
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("A:A")) + 3
                    Case "C", "С"
                        СтолбецОтчет = 6
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("F:F")) + 3
                    Case "A", "А"
                        СтолбецОтчет = 11
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("K:K")) + 3
                    Case "D"
                        СтолбецОтчет = 16
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("K:K")) + 3
                    Case Else
                        НайденаОценка = False
                End Select
                    If НайденаОценка = True Then
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет) = ЛистОтчет.Cells(СтрокаОтчет, 2)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 1) = ЛистОтчет.Cells(СтрокаОтчет, 3)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 2) = ЛистОтчет.Cells(СтрокаОтчет, 4)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 3) = ЛистОтчет.Cells(СтрокаОтчет, 9)
                        If ЛистОтчет.Cells(СтрокаОтчет, 8) > 1.1 Then
                            СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("U:U")) + 3
                            ЛистОценок.Cells(СтрокаОценка, 21) = ЛистОтчет.Cells(СтрокаОтчет, 2)
                            ЛистОценок.Cells(СтрокаОценка, 22) = ЛистОтчет.Cells(СтрокаОтчет, 3)
                            ЛистОценок.Cells(СтрокаОценка, 23) = ЛистОтчет.Cells(СтрокаОтчет, 4)
                            ЛистОценок.Cells(СтрокаОценка, 24) = ЛистОтчет.Cells(СтрокаОтчет, 9)
                        End If
                    End If
            End If
        СтрокаОтчет = СтрокаОтчет + 1
    Loop
    
End Sub
Изменено: Valo - 21.04.2019 16:57:44
Наша суть отражается в наших повторяющихся действиях. Отсюда следует, что совершенство есть не действие, а привычка. Аристотель.
 
UDF. Формула массива
Код
Function Seitkassym(iTbl As Range, arrClmn(), iPos$, iSc)
'iTbl - таблица исходных данных
'arrClmn - массив номеров столбцов для выборки из исходной таблицы
'iPos - искомая должность
'iSc - искомая оценка
Dim tmpArr$(), I&, J&, N&
arr = iTbl.Value
ReDim tmpArr(1 To Application.Caller.Rows.Count, 1 To 4): N = 1
For I = 1 To UBound(arr)
    If Trim(arr(I, 2)) = iPos And Trim(arr(I, 8)) = iSc Then
        For J = 1 To UBound(arrClmn)
            tmpArr(N, J) = arr(I, arrClmn(J))
        Next
        N = N + 1
    End If
Next
Seitkassym = tmpArr
End Function
Изменено: Sanja - 21.04.2019 17:24:28
Согласие есть продукт при полном непротивлении сторон
Страницы: 1
Наверх