如果另一个单元格包含特定文本，Excel中是否可以显示某个单元格？

Question

Hi everyone i have an excel document which is a list of people and the activities these people do, like:

 People programmming swimming golf David Yes Yes No Lucy Yes No Yes Martin No Yes Yes 

I need to have a list of activities counting the number of people that do that activity and theyr names. For example:

 Programming 2 people David Lucy Swimming 2 people David Martin 

I know i accomplish with an IF function but i don't want blank spaces between names, so i need a function that: if the person does the activity the name is added but if not, it checks the next person.

What can i use?

Answer 1

You seem fairly hell bent on the VBA approach and if that's the case, copy and paste the below code into a new module within your workbook ...

Option Explicit

Public Sub TransformData()
    Dim rngCells As Range, lngCol As Long, lngRow As Long, strHeader As String
    Dim lngWriteRow As Long, objDict As Scripting.Dictionary, arrNames() As String
    Dim objDestSheet As Worksheet, i As Long, x As Long

    Set objDestSheet = Worksheets("Transformed")
    Set objDict = New Scripting.Dictionary
    Set rngCells = Selection

    objDestSheet.Cells.Clear

    With rngCells
        For lngCol = 2 To .Columns.Count
            strHeader = .Cells(1, lngCol)

            ' Reset the array in case no names are found to have a yes next to them.
            ReDim Preserve arrNames(0)
            arrNames(0) = ""

            For lngRow = 2 To .Rows.Count
                If Left(UCase(.Cells(lngRow, lngCol)), 1) = "Y" Then
                    ReDim Preserve arrNames(UBound(arrNames) + 1)
                    arrNames(UBound(arrNames)) = .Cells(lngRow, 1)
                End If
            Next

            objDict.Add strHeader, arrNames
        Next
    End With

    With objDestSheet
        For i = 0 To objDict.Count - 1
            strHeader = objDict.Keys(i)
            arrNames = objDict.Items(i)

            strHeader = strHeader & " " & UBound(arrNames) & " people"

            lngWriteRow = lngWriteRow + 1
            .Cells(lngWriteRow, 1) = strHeader

            For x = 1 To UBound(arrNames)
                lngWriteRow = lngWriteRow + 1
                .Cells(lngWriteRow, 1) = arrNames(x)
            Next

            lngWriteRow = lngWriteRow + 1
        Next
    End With

    objDestSheet.Activate
End Sub

... then create a sheet in your workbook called Transformed .

Add a reference to the below library ...

Now select your matrix of data and run the macro.

I hope it works for you.