counting blocks and histogram of text data - excel-formula

Question

I have the following challenge. I need to count how many blocks of info are in the column and what the size of each block, using Excel 2013.
Example (data in columns A... actual size of the columns 40.000 entries)
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
In this example we have
B4B4 has 4 blocks (1 size 12, 1 size 10, 2 size 2)
7Z7Z has 3 blocks (1 size 4, 1 size 3, 1 size 1)
D8D8 has 1 block size 1
Z2Z2 has 1 block size 1
If possible not using VBA, because I'm not familiar with it.

Answer 1

You could also use a combination of Excel formulae and a pivot table to do it.
Set up a counter in column B which starts at one for each new block:-
IF(A2=A1,B1+1,1)
Set up a label in column C which shows a "Yes" for the end of each block:-
=IF(A3=A2,"No","Yes")
Insert a pivot table which uses the "Data" column for row labels, the "Count" column for column labels, a count field for the Sigma field, and the "Label" column as a filter:-
The pivot table appears like this:-

Answer 2

Here's some VBA code that will do what you want (if I understand correctly)
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
Edited to write to data to sheet 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