Help using CountA or ??

[Cowichandave]

Each number in Column A is a person in Col B. I need a count for total entries in Col D to G for each person. Would CountA work. I am lost on this one. Any help would be appreciated.

A​	B​	C​	D​	E​	F​	G​
1	BobT​
	1	49N01
	2	BAS16
	3	DRR03		150.00​
	4	ATB19	339.99​
	5	AUM02
	6	BAY05
	7	BUI05			199.99​
	8	CAC03	399.94​		639.90​	2339.96​
	9	CAS21
	10	COM45		140.00​
	11	CONT07		298.93​	119.77​
			2​	3​	3​	1​
2	BonR​
	1	15520
	2	CRE06	439.00​
	3	CAP21			195.00​
	4	CARL07	215.47​
	5	CHE11				100.00​
			2​	0​	1​	1​
3​	ChrisB​
	1	CHI18				114.50​
	2	4TH01	2066.89​		1129.94​	149.70​
	3	AND12
	4	15520	86.20​		819.20​
	5	ATC21
	6	CAN91			1095.00​
	7	CAO01	259.56​	1691.00​
	8	CAR32		1316.93​
	9	CSC07	490.00​		490.00​
	10	COM44	909.20​		573.54​	975.30​
	11	DOW04		568.97​
	12	ENB03
	13	FAL04
	14	INF33			303.24​
	15	MAS13	515.52​	1740.35​	711.64​	769.28​
			6​	4​	7​	4​

 

[Alex Blakenburg]

See if this works for you.

Sub SectionCount()

    Dim ws As Worksheet
    Dim rngFull As Range
    Dim arr As Variant
    Dim rowLast As Long, i As Long
    Dim empRowFirst As Long, empRowLast As Long
    
    Set ws = ActiveSheet
    With ws
        rowLast = .Cells(Rows.Count, "C").End(xlUp).Row + 2 ' Section includes 2 empty rows
        Set rngFull = .Range("A1:G" & rowLast)
        arr = rngFull.Value
    
        For i = 1 To UBound(arr)
            If arr(i, 3) <> "" Then
                If arr(i - 1, 3) = "" Then
                    empRowFirst = i
                ElseIf arr(i + 1, 3) = "" Or i = (UBound(arr) - 1) Then
                    empRowLast = i
                    .Range("D" & i + 1 & ":G" & i + 1).Formula = _
                        "=COUNT(" & .Range("D" & empRowFirst & ":D" & empRowLast).Address(1, 0) & ")"
                End If
            End If
        Next i
    End With

End Sub

 

[Cowichandave]

See if this works for you.

Sub SectionCount()

    Dim ws As Worksheet
    Dim rngFull As Range
    Dim arr As Variant
    Dim rowLast As Long, i As Long
    Dim empRowFirst As Long, empRowLast As Long
   
    Set ws = ActiveSheet
    With ws
        rowLast = .Cells(Rows.Count, "C").End(xlUp).Row + 2 ' Section includes 2 empty rows
        Set rngFull = .Range("A1:G" & rowLast)
        arr = rngFull.Value
   
        For i = 1 To UBound(arr)
            If arr(i, 3) <> "" Then
                If arr(i - 1, 3) = "" Then
                    empRowFirst = i
                ElseIf arr(i + 1, 3) = "" Or i = (UBound(arr) - 1) Then
                    empRowLast = i
                    .Range("D" & i + 1 & ":G" & i + 1).Formula = _
                        "=COUNT(" & .Range("D" & empRowFirst & ":D" & empRowLast).Address(1, 0) & ")"
                End If
            End If
        Next i
    End With

End Sub

Works perfect. Thank you. Is there anyway to make the answers in bold and center and red

 

[Alex Blakenburg]

Works perfect. Thank you. Is there anyway to make the answers in bold and center and red

Sure. Additional code in blue.

Sub SectionCount_v02()

    Dim ws As Worksheet
    Dim rngFull As Range
    Dim arr As Variant
    Dim rowLast As Long, i As Long
    Dim empRowFirst As Long, empRowLast As Long
    
    Set ws = ActiveSheet
    With ws
        rowLast = .Cells(Rows.Count, "C").End(xlUp).Row + 2 ' Section includes 2 empty rows
        Set rngFull = .Range("A1:G" & rowLast)
        arr = rngFull.Value
    
        For i = 1 To UBound(arr)
            If arr(i, 3) <> "" Then
                If arr(i - 1, 3) = "" Then
                    empRowFirst = i
                ElseIf arr(i + 1, 3) = "" Or i = (UBound(arr) - 1) Then
                    empRowLast = i
                    .Range("D" & i + 1 & ":G" & i + 1).Formula = _
                        "=COUNT(" & .Range("D" & empRowFirst & ":D" & empRowLast).Address(1, 0) & ")"
                        
                    ' Format
                    With .Range("D" & i + 1 & ":G" & i + 1)
                        .HorizontalAlignment = xlCenter
                        .Font.Color = -16776961
                        .Font.Bold = True
                    End With
                End If
            End If
        Next i
    End With

End Sub