Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Фильтрация результатов опроса по выбранному вопросу
 
#1
20.04.2021 11:23:51
Коллеги, друзья, добрый день!
Нужна Ваша помощь в решении следующей задачи (пример прикладываю):
Есть массив данных по итогам опроса: Id респондента, Вопрос, Ответ.
Необходимо сделать такой свод данных из массива (реальный массив значительно больше примера в 100 раз), чтобы была возможность фильтровать ответ, к примеру на первый вопрос и видеть, как отобранные респонденты отвечают на остальные.
Фильтрация может быть по нескольким вопросам.
Хотелось бы это видеть в конечно своде, чтобы перестраивались процентные соотношения.
Спасибо!
 
 
 
#2
20.04.2021 12:04:51
Фильтрует ответ по выделенной ячейке.
Код
Sub Опорос()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    
    Dim brr As Variant
    brr = JobArr(arr, ActiveCell)
    
    OutArr brr, ActiveSheet
End Sub

Sub OutArr(brr As Variant, sh As Worksheet)
    With Workbooks.Add(1)
        With .Sheets(1)
            sh.Cells(1, 1).Resize(1, UBound(brr, 2)).EntireColumn.Copy .Cells(1, 1)
            .Cells(1, 1).Resize(1, UBound(brr, 2)).EntireColumn.ClearContents
            .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        End With
    End With
End Sub

Function JobArr(arr As Variant, cl As Range) As Variant
    Dim brr As Variant
    Dim u As Long
    u = cl.Row
    If u <= UBound(arr, 1) Then
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Dim y As Long
        For y = 2 To UBound(arr, 1)
            If arr(y, 2) = arr(u, 2) Then
            If arr(y, 3) = arr(u, 3) Then
                dic.Item(arr(y, 1)) = 0
            End If
            End If
        Next
        
        ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        Dim arrID As Variant
        arrID = dic.Keys()
        Dim j As Long
        Dim x As Byte
        For y = 1 To UBound(arr, 1)
        For u = 0 To UBound(arrID)
            If arr(y, 1) = arrID(u) Or y = 1 Then
                j = j + 1
                For x = 1 To UBound(arr, 2)
                    brr(j, x) = arr(y, x)
                Next
                Exit For
            End If
        Next
        Next
    End If
    JobArr = brr
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        GetArr = .Range(.Cells(1, 1), .Cells(y, 3))
    End With
End Function
 
 
 
#3
20.04.2021 12:11:51
Про проценты не поняла. Фильтры - вариант в power query
 
 
 
#4
20.04.2021 13:08:44
Добрый день. Спасибо.
Правильно ли я понимаю, что табФильтр это по сути ручной ввод параметров для дальнейшего отбора?

В моем запросе необходимо создать некий инструмент, который будет позволять в итоге отбирая ответы на один или несколько вопросов, сразу видеть перестроение остальных данных с учетом зафиксированных фильтров. Т.е. возможно постоянно изменяя фильтры, анализировать итоговые ответы.
 
 
 
#5
20.04.2021 13:33:39
Цитата
Влад написал:
Правильно ли я понимаю, что табФильтр это по сути ручной ввод параметров для дальнейшего отбора?
Да, если в ней несколько строк, то они применяются как "И".

Насчет "необходимо" - вы бы нарисовали пример, как оно должно выглядеть. А то у вас есть некая идея, но ее надо сначала угадать.
 
 
 
#6
20.04.2021 13:59:58
МатросНаЗебре, спасибо!
Для себя буду использовать данный запрос.
Для итогового решения немного не подходит, так как постоянная выгрузка в новую книгу и нет возможности фильтрации нескольких вариантов вопросов и ответов.

Хотелось бы, чтобы функционал работал по логике схоже, как таблица с горизонтальными данными. Столбец с ID, столбец с Вопросом Пол, столбец с вопросом Настроение и тд.
Когда фильтруешь пол М, далее настроение Отличное и видишь как эти респонденты ответили на отношение к мороженому.
Вопросов может быть очень много и горизонтальное построение будет не читабельно. К тому же могут быть множественные варианты ответов.

Ну что-то похожее на срез в своднике. Выбрал Вопросы, выбрал ответы, таблица перестроилась.
Только что-то мне подсказывает, что при таком формате сэта это весьма проблематично.
 
 
 
#7
20.04.2021 14:10:04
Так позволяет фильтровать по нескольким ответам.
Код
Sub МультиОпорос()
    On Error Resume Next
        ActiveSheet.Cells.AutoFilter
    On Error GoTo 0

    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    
    Dim rn As Range
    On Error Resume Next
    Set rn = Intersect(ActiveSheet.UsedRange, Selection, Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)))
    On Error GoTo 0
    
    If Not rn Is Nothing Then
        Dim cl As Range
        For Each cl In rn
            arr = JobArr(arr, cl)
'            OutArr arr, ActiveSheet
        Next
        
        OutArr arr, ActiveSheet
    End If
End Sub

Sub OutArr(brr As Variant, sh As Worksheet)
    With sh
        '.Cells(1, 1).Resize(1, UBound(brr, 2)).EntireColumn.ClearContents
        .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
        .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)).AutoFilter Field:=4, Criteria1:="1"
    End With
End Sub

Function JobArr(arr As Variant, cl As Range) As Variant
    Dim u As Long
    u = cl.Row
    If u <= UBound(arr, 1) Then
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Dim y As Long
        For y = 2 To UBound(arr, 1)
            If arr(y, 2) = arr(u, 2) Then
            If arr(y, 3) = arr(u, 3) Then
                dic.Item(arr(y, 1)) = 0
            End If
            End If
        Next
        
        'ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        Dim arrID As Variant
        arrID = dic.Keys()
        Dim j As Long
        Dim x As Byte
        For y = 2 To UBound(arr, 1)
            If arr(y, 4) = 1 Then
                arr(y, 4) = 0
                For u = 0 To UBound(arrID)
                    If arr(y, 1) = arrID(u) Then
                        arr(y, 4) = 1
                        Exit For
                    End If
                Next
            End If
        Next
    End If
    JobArr = arr
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, 4))
        For y = 2 To UBound(arr, 1)
            arr(y, 4) = 1
        Next
        GetArr = arr
    End With
End Function
 
 
 
Страницы: 1
Наверх