Question

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

示例（列A中的数据...列的实际大小40.000个条目） B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 7Z7Z 7Z7Z 7Z7Z B4B4 B4B4 Z2Z2 7Z7Z 7Z7Z 7Z7Z 7Z7Z B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 B4B4 D8D8 7Z7Z B4B4 B4B4

在这个例子中我们有 B4B4有4个块（1个大小12,1个大小10,2个大小2） 7Z7Z有3个积木（1尺寸4,1尺寸3,1尺寸1） D8D8有1个块大小为1 Z2Z2具有1个块大小1

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

Answer 1

这里有一些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

Answer 2

您还可以使用Excel公式和数据透视表的组合来执行此操作。

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

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

在C栏中设置一个标签，显示＆＃34;是＆＃34;每个块的结尾： -

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

enter image description here

插入一个使用＆＃34;数据＆＃34;的数据透视表。行标签的列，＆＃34;计数＆＃34;列标签的列，Sigma字段的计数字段以及＆＃34;标签＆＃34;列作为过滤器： -

enter image description here

数据透视表如下所示： -

enter image description here

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

2 个答案: