Excel formula 文本数据的计数块和直方图

我面临以下挑战。我需要使用Excel 2013计算列中有多少信息块，以及每个信息块的大小

列A中的示例数据。。。列的实际大小为40.000个条目 B4 B4 B4 B4 B4 B4 B4 B4 B4 B4 B4 B4 7Z7Z 7Z7Z 7Z7Z B4 B4 Z2Z2 7Z7Z 7Z7Z 7Z7Z 7Z7Z B4 B4 B4 B4 B4 B4 B4 B4 B4 B4 D8D8 7Z7Z B4 B4

在这个例子中，我们有 B4有4个区块，1个尺寸为12，1个尺寸为10，2个尺寸为2 7Z7Z有3个块1个尺寸4，1个尺寸3，1个尺寸1 D8D8有1个块大小1 Z2Z2有1个块大小为1

---

如果可能的话，不要使用VBA，因为我不熟悉它。

这里有一些VBA代码，如果我理解正确，它可以做你想做的事情

Sub test()
    Dim x As Integer
    x = 1
    Dim allStrings() As String
    ReDim allStrings(0) 'array starts at 1, 0 will be null
    Dim datablocks() As Integer
    ReDim datablocks(0, 0)
    Dim uniqueflag As Boolean
    uniqueflag = True
    Dim blockcount As Integer
    blockcount = 1
    Dim Blocks As Integer
    Blocks = 1
    Dim strReport As String

    Do While Cells(x, 1) <> ""
    'get unique strings
        For y = 0 To UBound(allStrings)
            If Cells(x, 1).Value = allStrings(y) Then
                uniqueflag = False
            End If
        Next y
        If uniqueflag = True Then
        'add unique string to array
            ReDim Preserve allStrings(UBound(allStrings) + 1)
            allStrings(UBound(allStrings)) = Cells(x, 1).Value
        Else
            uniqueflag = True 'reset flag
        End If
        x = x + 1
    Loop

    ReDim datablocks(UBound(allStrings), 0)

    For z = 1 To x - 1

    If z > 1 And newblock = flase Then
        If Cells(z, 1).Value = Cells(z - 1, 1).Value Then
            'current cell is same value as the last
            blockcount = blockcount + 1
        Else
            For w = 1 To UBound(allStrings)
            'new block starts, record previous
                 If Cells(z - 1, 1).Value = allStrings(w) Then 'determine which string the block
                    ReDim Preserve datablocks(UBound(allStrings), Blocks) 'expand array
                    datablocks(w, Blocks) = blockcount
                    Blocks = Blocks + 1
                End If
            Next w

            If z = x - 1 Then
                'last item is a block of 1
                For w = 1 To UBound(allStrings)
                    If Cells(z, 1).Value = allStrings(w) Then  'determine which string the block
                        ReDim Preserve datablocks(UBound(allStrings), Blocks) 'expand array
                        datablocks(w, Blocks) = 1
                        Blocks = Blocks + 1
                    End If
                Next w
            End If
            blockcount = 1
        End If
    End If

    Next z




    Dim uniqueblocksizes() As Integer
    ReDim uniqueblocksizes(0)
    Dim sizeexists As Boolean
    sizeexists = False

    For w = 1 To UBound(allStrings)

        For r = 1 To Blocks - 1
            If datablocks(w, r) <> 0 Then
                For q = 0 To UBound(uniqueblocksizes)
                If uniqueblocksizes(q) = datablocks(w, r) Then
                    sizeexists = True
                End If
                Next q
                If sizeexists = False Then
                    ReDim Preserve uniqueblocksizes(UBound(uniqueblocksizes) + 1)
                    uniqueblocksizes(UBound(uniqueblocksizes)) = datablocks(w, r)
                End If
                sizeexists = False
            End If
        Next r

    Next w

    Dim tally As Integer
    Dim summary() As String
    ReDim summary(UBound(allStrings))
    For w = 1 To UBound(allStrings) 'for strings
        summary(w) = "'" & allStrings(w) & "' Has blocks ("
    Next w

    tally = 0
    For q = 1 To UBound(uniqueblocksizes) 'for occurences of blocks
        For w = 1 To UBound(allStrings) 'for strings
            For r = 1 To Blocks - 1 'for blocks datablocks(w, r)
                If uniqueblocksizes(q) = datablocks(w, r) Then
                    tally = tally + 1
                End If
            Next r
            'MsgBox (tally & " sets of '" & allStrings(w) & "' size " & uniqueblocksizes(q))
            If tally <> 0 Then
                summary(w) = summary(w) & " " & tally & " of size " & uniqueblocksizes(q) & ", "
            End If
            tally = 0
        Next w
    Next q

    For w = 1 To UBound(allStrings) 'for strings
        summary(w) = summary(w) & ")"
        summary(w) = Replace(summary(w), ", )", ")")
        MsgBox (summary(w))
    Next w





    End Sub

编辑以将数据写入第3页

Sub test()
    Dim x As Integer
    x = 1
    Dim allStrings() As String
    ReDim allStrings(0) 'array starts at 1, 0 will be null
    Dim datablocks() As Integer
    ReDim datablocks(0, 0)
    Dim uniqueflag As Boolean
    uniqueflag = True
    Dim blockcount As Integer
    blockcount = 1
    Dim Blocks As Integer
    Blocks = 1
    Dim strReport As String
    Sheets(1).Activate
    Do While Cells(x, 1) <> ""
    'get unique strings
        For y = 0 To UBound(allStrings)
            If Cells(x, 1).Value = allStrings(y) Then
                uniqueflag = False
            End If
        Next y
        If uniqueflag = True Then
        'add unique string to array
            ReDim Preserve allStrings(UBound(allStrings) + 1)
            allStrings(UBound(allStrings)) = Cells(x, 1).Value
        Else
            uniqueflag = True 'reset flag
        End If
        x = x + 1
    Loop

    ReDim datablocks(UBound(allStrings), 0)

    For z = 1 To x - 1

    If z > 1 And newblock = flase Then
        If Cells(z, 1).Value = Cells(z - 1, 1).Value Then
            'current cell is same value as the last
            blockcount = blockcount + 1
        Else
            For w = 1 To UBound(allStrings)
            'new block starts, record previous
                 If Cells(z - 1, 1).Value = allStrings(w) Then 'determine which string the block
                    ReDim Preserve datablocks(UBound(allStrings), Blocks) 'expand array
                    datablocks(w, Blocks) = blockcount
                    Blocks = Blocks + 1
                End If
            Next w

            If z = x - 1 Then
                'last item is a block of 1
                For w = 1 To UBound(allStrings)
                    If Cells(z, 1).Value = allStrings(w) Then  'determine which string the block
                        ReDim Preserve datablocks(UBound(allStrings), Blocks) 'expand array
                        datablocks(w, Blocks) = 1
                        Blocks = Blocks + 1
                    End If
                Next w
            End If
            blockcount = 1
        End If
    End If

    Next z




    Dim uniqueblocksizes() As Integer
    ReDim uniqueblocksizes(0)
    Dim sizeexists As Boolean
    sizeexists = False

    For w = 1 To UBound(allStrings)

        For r = 1 To Blocks - 1
            If datablocks(w, r) <> 0 Then
                For q = 0 To UBound(uniqueblocksizes)
                If uniqueblocksizes(q) = datablocks(w, r) Then
                    sizeexists = True
                End If
                Next q
                If sizeexists = False Then
                    ReDim Preserve uniqueblocksizes(UBound(uniqueblocksizes) + 1)
                    uniqueblocksizes(UBound(uniqueblocksizes)) = datablocks(w, r)
                End If
                sizeexists = False
            End If
        Next r

    Next w

    Dim tally As Integer
    'Dim summary() As String
    'ReDim summary(UBound(allStrings))
    'For w = 1 To UBound(allStrings) 'for strings
        'summary(w) = "'" & allStrings(w) & "' Has blocks ("
   ' Next w


    Dim tablerows As Integer
    tablerows = 2
    tally = 0
    Sheets(3).Cells(1, 1).Value = "Block Value"
    Sheets(3).Cells(1, 2).Value = "Block Size"
    Sheets(3).Cells(1, 3).Value = "Occurences"
    For q = 1 To UBound(uniqueblocksizes) 'for occurences of blocks
        For w = 1 To UBound(allStrings) 'for strings
            For r = 1 To Blocks - 1 'for blocks datablocks(w, r)
                If uniqueblocksizes(q) = datablocks(w, r) Then
                    tally = tally + 1
                End If
            Next r
            If tally <> 0 Then
                Sheets(3).Cells(tablerows, 1).Value = allStrings(w)
                Sheets(3).Cells(tablerows, 2).Value = uniqueblocksizes(q)
                Sheets(3).Cells(tablerows, 3).Value = tally
                tablerows = tablerows + 1
                'summary(w) = summary(w) & " " & tally & " of size " & uniqueblocksizes(q) & ", "
            End If
            tally = 0
        Next w
    Next q
    'reorder data


    'For w = 1 To UBound(allStrings) 'for strings
    '    summary(w) = summary(w) & ")"
    '    summary(w) = Replace(summary(w), ", )", ")")
    '    MsgBox (summary(w))
   'Next w





    End Sub

---

您还可以使用Excel公式和透视表的组合来完成此操作

在B列中设置一个计数器，每个新块从一开始：-

IF(A2=A1,B1+1,1)

在C列中设置一个标签，在每个块的末尾显示“是”：-

=IF(A3=A2,"No","Yes")

插入一个透视表，该透视表使用数据列作为行标签，计数列作为列标签，计数字段作为西格玛字段，标签列作为过滤器：-

透视表如下所示：-

---

澄清一下，当你说block时，你指的是cell，对吗？您需要计算同一字符串的出现次数，按A列中连续出现的次数分组？如果是这样的话，这将是非常容易做到的VBA，但我怀疑公式函数是否能够做到这一点是的…每个代码B4B4或7Z7z是一个不同的论坛网站，我们不使用感谢，或任何感谢的帮助，或签名。看见顺便说一句，这是“提前感谢”，而不是“提前感谢”。很好，它的效果正如预期的那样，但是有没有一种方法可以将信息作为表格而不是消息获取？请参见我的编辑。我没有费心把同一个字符串的行组合在一起，因为你可以用自动过滤器来实现