单个细胞中标准的多个结果

Question

所以我现在已经有一段时间了，我或者只是缺少一些东西或者只是愚蠢。基本上我正在尝试做类似于Excel中的countifs函数，你可以使用多个条件但不是返回一个计数我想在单个单元格中返回匹配的单元格值。

我已经为所有三个字段命名了范围，这些字段用于输入数字的结果，但现在我正在寻找一种方法来抓取每个案例和注释，并将它们放入透视单元格中，如上图所示。我不介意使用VBA实现这个甚至是公式，如果可能的话我已经完成了所有事情并且无法想象这个。

这基本上就是我想要实现的目标。

Answer 1

看起来您只是想总结数据。如果是这样，数据透视表将是您最简单和最好的选择 - 而且没有VBA代码或公式编写！我添加了一个额外的列用于计数目的，并创建了两个单独的数据透视表。下面是我放在一起的一个例子......希望这有帮助！

Answer 2

试试这段代码：

Sub Demo()
    Dim dict1 As Object, dictApp As Object, dictNotApp As Object
    Dim c1 As Variant, k As Variant, j As Variant
    Dim i As Long, lastRow As Long, rowCount As Long
    Dim rngName As Range, rngCase As Range, rngNotes As Range, rngFound As Range
    Dim FirstAddress As String, strApp As String, strNotApp As String, strNotes As String
    Dim dataSheet As Worksheet, outputSheet As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'set you worksheets here
    Set dataSheet = ThisWorkbook.Sheets("Sheet1")
    Set outputSheet = ThisWorkbook.Sheets("Sheet2")

    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dictApp = CreateObject("Scripting.Dictionary")
    Set dictNotApp = CreateObject("Scripting.Dictionary")

    'get last row with data
    lastRow = dataSheet.Cells(Rows.Count, "A").End(xlUp).Row
    'you can replace following ranges to your named ranges
    Set rngName = dataSheet.Range("A2:A" & lastRow)
    Set rngCase = dataSheet.Range("B2:B" & lastRow)
    Set rngNotes = dataSheet.Range("C2:C" & lastRow)

    'put unique names to dict1
    c1 = dataSheet.Range("A2:A" & lastRow)
    For i = 1 To UBound(c1, 1)
        dict1(c1(i, 1)) = 1
    Next i

    rowCount = 2 'this is the starting row no for ouputSheet, row 1 being the header
    For Each k In dict1.keys
        strApp = ""
        strNotApp = ""
        strNotes = ""

        'for each unique name get the values of case and notes
        Set rngFound = dataSheet.Columns(1).Find(What:=k, LookAt:=xlWhole, MatchCase:=False)
        If Not rngFound Is Nothing Then
            FirstAddress = rngFound.Address
            Do
                If rngFound.Offset(0, 2) = "Approved" Then
                    'if value of notes is approved put data in dictApp
                    dictApp.Add rngFound.Offset(0, 1), rngFound.Offset(0, 2)
                Else
                    'if value of notes is not approved put data in dictNotApp
                    dictNotApp.Add rngFound.Offset(0, 1), rngFound.Offset(0, 2)
                End If

                Set rngFound = rngName.FindNext(rngFound)
            Loop While Not rngFound Is Nothing And rngFound.Address <> FirstAddress

            'create case string for approved notes
            For Each j In dictApp.keys
                If strApp = "" Then
                    strApp = j
                Else
                    strApp = strApp & vbCrLf & j
                End If
            Next
            'create case and notes string for notes not approved
            For Each j In dictNotApp.keys
                If strNotApp = "" Then
                    strNotApp = j
                    strNotes = dictNotApp(j)
                Else
                    strNotApp = strNotApp & vbCrLf & j
                    strNotes = strNotes & vbCrLf & dictNotApp(j)
                End If
            Next
        End If

        'display values in outputSheet
        outputSheet.Cells(rowCount, 1) = k
        outputSheet.Cells(rowCount, 2) = Application.WorksheetFunction.CountIf(rngName, k)
        outputSheet.Cells(rowCount, 3) = Application.WorksheetFunction.CountIfs(rngName, k, rngNotes, "<>Approved")
        outputSheet.Cells(rowCount, 4) = strApp
        outputSheet.Cells(rowCount, 5) = strNotApp
        outputSheet.Cells(rowCount, 6) = strNotes

        dictApp.RemoveAll
        dictNotApp.RemoveAll
        rowCount = rowCount + 1
    Next k
    'center align the data
    With outputSheet.UsedRange
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
End Sub

见图片参考：