Страницы: 1
RSS
Промежуточный итог по медиане с изменяющимися данными (с помощью фильтра)
 
Добрый день.
Возник вопрос, как применить промежуточные итоги по медиане с учетом изменяющихся данных.
Т.е. есть исходный лист, в котором данные по региону, должности и зарплаты (условной).
Создан дополнительный лист в котором собирается информация по региону, должности и медиане в зависимости от этих условий.
Как сделать, что бы при работе с фильтрами медиана пересчитывалась (по аналогии с промежуточными итогами) с учетом выбранных условий (в ячейке С1).
Файл прикрепила
 
Доброе время суток.
Вариант на Power Pivot.
 
Вариант, с помощью пользовательской функций.
Изменено: nbaengineer - 22.06.2021 08:05:50
Вредить легко, помогать трудно.
 
AnnaD543926, что-то мне кажется вы всех запутали и хотели получить медиану медиан в с1 - так?

Если да, то массивная
=MEDIAN(IF(SUBTOTAL(109;OFFSET(C1;ROWS(C4:C40)-1;))<>0;C4:C40))
По вопросам из тем форума, личку не читаю.
 
Спасибо, всем за ответы.
Но наверное, я и в правду всех запутала. Постараюсь объяснить.
на листе " Июнь'21 раб" - у меня исходные данные
на листе "Расч_медиан,срав с срЗП_рег_дож" - через формулы просчитана медиана с учетом должности и региона
А теперь мне нужно, что бы при фильтрование данных на листе "Расч_медиан,срав с срЗП_рег_дож", например по должности Агроном, у меня просчитывалась медиана с учетом данных с листа "Июнь'21 раб"
БМВ, Ваша формула работает в случае сводных данных на листе "Расч_медиан,срав с срЗП_рег_дож", но без учета кол-ва данных с листа "Июнь'21 раб". Т.е. по Вашей формуле медиана по агрономам = 550 000, но на самом деле она должна быть =695 000
 
Вариант макросом.
Код
Sub Агрономы()
    
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim sh1 As Worksheet:    Set sh1 = Sheets("Июнь'21 раб")
    Dim sh2 As Worksheet:    Set sh2 = Sheets("Расч_медиан,срав с срЗП_рег_дож")
    
    Dim ar1 As Variant
    Dim arV As Variant
    Dim y As Long
    Dim u As Long
    Dim x As Byte
    With sh1
        ar1 = .Range(.Cells(1, 2), .Cells(.Rows.Count, 4).End(xlUp))
        ReDim arV(1 To UBound(ar1, 1), 1 To UBound(ar1, 2))
        u = 0
        For y = 6 To UBound(ar1, 1)
            If Not .Rows(y).Hidden Then
                u = u + 1
                For x = 1 To UBound(ar1, 2)
                    arV(u, x) = ar1(y, x)
                Next
            End If
        Next
    End With
    If u = 0 Then Exit Sub
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    Dim sh As Worksheet
    Set sh = wb.Sheets(1)
    Dim r As Range
    Set r = sh.Cells(1, 1).Resize(u, UBound(arV, 2))
    r = arV
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    arV = r
    wb.Saved = True
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = UBound(arV, 1) To 1 Step -1
        For u = y - 1 To 1 Step -1
            If u = 0 Then Exit For
            If arV(u, 1) <> arV(y, 1) Then Exit For
            If arV(u, 2) <> arV(y, 2) Then Exit For
        Next
        u = u + 1
        With sh.Cells(u, 4)
            .FormulaR1C1 = "=MEDIAN(RC[-1]:R" & y & "C[-1])"
            dic.Item(Join(Array(arV(u, 1), arV(u, 2)), vbTab)) = .Value
            .Clear
        End With
        y = u
    Next
    wb.Saved = True
    wb.Close False
    
    Dim ar2 As Variant
    With sh2
        Set r = .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 3))
        ar2 = r
    End With
    
    Dim s As String
    For y = 1 To UBound(ar2, 1)
        s = Join(Array(ar2(y, 1), ar2(y, 2)), vbTab)
        If dic.Exists(s) Then
            ar2(y, 3) = dic.Item(s)
        Else
            ar2(y, 3) = Empty
        End If
    Next
    r = ar2
    r.Parent.Parent.Activate
    r.Parent.Select
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
End Sub
Так захотелось агрономом в Воронеже стать, учитывая ЗП за июнь )
 
МатросНаЗебре,я бы тоже хотела поработать агроном)
У меня макрос срабатывает, как то не так.
При отборе все тех же агрономов и запуска макроса - подтягивается рандомная информация: Должность через строчку: то агроном, то Воронеж. А в медиану подтягивается: Воронеж/ 1 100 000.
Пример с тем что вышло - вложила

PS: МатросНаЗебре, возможно я что-то делаю не так :D  
Страницы: 1
Наверх