Excel VBA Loop through Column Range to Mark Section Headers

[Lantern]

I have an Excel parts list in which the part section headers are to be hidden if no parts are selected within the section.

I need to loop through a column range that contains a formula-generated index to create a filter in the adjacent column. The part qty may be in one of many columns, so I created the Index to mark the part rows. Section rows that contain a part qty (as described below) are to be marked with a Y.

I've been testing my loops on a sample file that only shows an Index Column with no part information shown.

A section row starts where an Index Row = 1 and extends to where the next Index Row = 1.

Index Values:
0 = Blank Row (Desired Y/N result = N)
1 = Section Row (Desired Y/N result = Y if any parts in the section have a Qty > 0)
2 = Part Row with Qty = 0 (Desired Y/N result = N)
3 = Part Row with Qty > 0 (Desired Y/N result = Y)

The Index Col always starts at C4 and extends to the last row. There will be nothing in the file past the last parts row.

The Index Column can be a few to hundreds of rows long with zero to many variable length sections.

Suggestions, please.

Thanks.

Sample file below . . .

COUNT TEST 8.xlsm
	B	C	D	E	F	G	H	I
2
3		Formula Generated Index	Desired Y/N VBA Results			Parts Row Index Key	Parts Row Description
4		1	Y			0	Blank
5		3	Y			1	Section Header
6		2	N			2	Blank Part
7		2	N			3	Part w/Qty
8		2	N
9		3	Y
10		3	Y
11		2	N
12		2	N
13		3	Y
14		2	N
15		0	N
16		1	N
17		2	N
18		2	N
19		2	N
20		2	N
21		0	N
22		2	N
23		2	N
24		2	N
25		0	N
26		2	N
27		1	Y
28		0	N
29		3	Y
30		3	Y
31		3	Y
32		3	Y
33		2	Y
34		0	N
35		1	N
36		2	N
37		2	N
38		2	N
39		2	N
40		0	N
41		0	N
42		0	N
43
Sheet1

 

[Lantern]

Same request as above with a revised sample data set (below) and my VBA attempt.

Note, the VBA code does nothing is Col C is empty starting at C4 and below.

This code comes close to properly marking Section Headers with filled part rows but I can't get the counter to properly reset. This causes Y/N errors in some Section Header rows.

Suggestions, please.

Sub IndexSection_Counts()
Application.ScreenUpdating = False
    Dim shTestSheet As Worksheet
    Dim rwIndex As Range
    Dim rwSectionIndex As Range
    Dim LastSheetRow As Long
    Dim CurrentSectionRow As Long
    Dim CurrentSectionCounter As Long
    '
    Set shTestSheet = ActiveSheet
    LastSheetRow = LastCell(shTestSheet).Row 'By Function Below
    '
    For Each rwIndex In shTestSheet.Range("C4:C" & LastSheetRow).Rows
    If rwIndex.Cells.Value = 1 Then
        CurrentSectionRow = rwIndex.Row
        CurrentSectionCounter = 0
        For Each rwSectionIndex In shTestSheet.Range("C" & CurrentSectionRow & ":" & "C" & LastSheetRow).Rows
        If rwSectionIndex.Value <> 1 Then
            If rwSectionIndex.Value = 0 Then
                rwSectionIndex.Cells.Offset(0, 1).Value = "N"
                rwSectionIndex.Cells.Offset(0, 2).Value = CurrentSectionCounter 'For Testing
            ElseIf rwSectionIndex.Value = 2 Then
                rwSectionIndex.Cells.Offset(0, 1).Value = "N"
                rwSectionIndex.Cells.Offset(0, 2).Value = CurrentSectionCounter 'For Testing
            ElseIf rwSectionIndex.Value = 3 Then
                rwSectionIndex.Cells.Offset(0, 1).Value = "Y"
                CurrentSectionCounter = CurrentSectionCounter + 1
                rwSectionIndex.Cells.Offset(0, 2).Value = CurrentSectionCounter 'For Testing
            End If
        End If
            If CurrentSectionCounter > 0 Then
                Range("C" & CurrentSectionRow & ":" & "C" & CurrentSectionRow).Cells.Offset(0, 1).Value = "Y"
            Else
                 Range("C" & CurrentSectionRow & ":" & "C" & CurrentSectionRow).Cells.Offset(0, 1).Value = "N"
            End If
            Range("C" & CurrentSectionRow).Cells.Offset(0, 2).Value = CurrentSectionCounter 'For Testing
        Next rwSectionIndex
    End If
    Next rwIndex
Application.ScreenUpdating = True
End Sub
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Function LastCell(ws As Worksheet) As Range
'
Dim lastRow&, LastCol%
On Error Resume Next
With ws
' ---- Find Last Row
lastRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
' ---- Find Last Col
LastCol% = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
End With
' ---- Initialize a Range object variable for the last populated row.
Set LastCell = ws.Cells(lastRow&, LastCol%)
End Function
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'

COUNT TEST 10.xlsm
	B	C	D	E	F	G	H	I	J	K
2		Data	VBA Results
3	Line	Formula Generated Index	Actual Y/N VBA Results	Section Parts Count (For Testing)		Desired Y/N VBA Results		Parts Row Index Key	Parts Row Description	Desired Y/N VBA Results
4	1	1	Y	8		Y		0	Blank	N
5	2	3	Y	1		Y		1	Section Header	Y
6	3	2	N	1		N		1	Section Header - No Parts in Section	N
7	4	2	N	1		N		2	Blank Part	N
8	5	0	N	1		N		3	Part w/Qty	Y
9	6	3	Y	2		Y
10	7	3	Y	3		Y
11	1	2	N	3		N
12	2	2	N	3		N
13	3	2	N	3		N
14	1	1	Y	5		Y
15	2	2	N	0		N
16	3	3	Y	1		Y
17	4	0	N	1		N
18	5	3	Y	2		Y
19	6	0	N	2		N
20	8	3	Y	3		Y
21	9	2	N	3		N
22	1	1	Y	2		N
23	2	2	N	0		N
24	3	0	N	0		N
25	4	2	N	0		N
26	1	1	Y	2		N
27	2	0	N	0		N
28	3	2	N	0		N
29	4	0	N	0		N
30	5	2	N	0		N
31	6	0	N	0		N
32	1	1	Y	2		Y
33	2	3	Y	1		Y
34	3	2	N	1		N
35	4	3	Y	2		Y
36	5	2	N	2		N
37	6	0	N	2		N
38	7	0	N	2		N
Sections

 

[Lantern]

I'm bumping this up to see if I can get some helpful input.

I've tried many variations of my loops to select the section headers, but I still can't get the section part counts to register correctly in the section header rows.

The code above still reflects my best effort to date.

Suggestions, please.

 

[PeteWright]

Hi @Lantern
I wrote some code that should work for your first post. Just make sure to select a cell in the correct sheet (since I wrote the code for the "Active Sheet")

Please try it on a copy of your data.

Public Sub IndexSection_Counts()
   Application.ScreenUpdating = False
   
   Dim FirstRow As Long
   Dim LastRow As Long
   Dim SectionStart As Long
   Dim SectionEnd As Long
   Dim Qty As Long
   Dim i As Long
   Dim j As Long
   FirstRow = 4
   LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
   For i = FirstRow To LastRow
      If Cells(i, 3) = 1 Then
         SectionStart = i
         SectionEnd = NextSectionIndex(i, 3, LastRow)
         Qty = 0
         
         For j = SectionStart To SectionEnd
            Select Case Cells(j, 3)
               Case 0 Or "0"
                  Cells(j, 4) = "N"
               Case 2 Or "2"
                  Cells(j, 4) = "N"
               Case 3 Or "3"
                  Cells(j, 4) = "Y"
                  Qty = Qty + 1
            End Select
         Next j
         
         If Qty > 0 Then
            Cells(SectionStart, 4) = "Y"
         Else
            Cells(SectionStart, 4) = "N"
         End If
         
      End If
      Qty = 0
   Next i
   
   Application.ScreenUpdating = True
End Sub

Private Function NextSectionIndex(PreviousSectionIndex As Long, CurrentColumn As Long, LastRow As Long) As Long
   Dim i As Long
   
   For i = PreviousSectionIndex + 1 To LastRow
      If Cells(i, CurrentColumn) = 1 Then
         NextSectionIndex = i
         Exit Function
      End If
   Next i
   
   NextSectionIndex = LastRow
End Function

I've run the code on your the data sheet you provided and got exactly the same results as you wanted.


If you're lucky with the result, I'll get on your next post...

Until then

Best regards
Pete

 

[Lantern]

Pete,

Your code is so sweet. Thanks.

If the first cell in the Index column has a 1 (to indicate a caption row), the code runs as expected.

One requirement I forgot to indicate with my sample file is there is a possibility the Index column can start with a 0, 2 or 3 (not with a 1 that indicates a caption row.) Without the 1 in the first row, the code skips down to the first row with a 1, then runs just fine.

This was my miss.

If a file happens to have no starting caption row, how can I mark the caption-less groups of first rows as well?

Thanks.

 

[Akuini]

deleted: wrong code

 

[Akuini]

@Lantern
Another option to try:

Sub Lantern_2()
Dim i As Long
Dim va, vb
Dim flag As Boolean

va = Range("C4", Cells(Rows.Count, "C").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)
If va(1, 1) <> 1 Then flag = True
For i = 1 To UBound(va, 1)
    If va(i, 1) = 3 Then vb(i, 1) = "Y" Else vb(i, 1) = "N"
    If va(i, 1) = 1 Then n = i: flag = False
        If flag = False Then
            If va(i, 1) = 3 Then
                vb(n, 1) = "Y"
                flag = True
            End If
        End If
Next
Range("D4").Resize(UBound(vb, 1), 1) = vb
End Sub

 

[Lantern]

Akuini,

Another coding gem. Thanks.

This does it.

I'm going to mark this as the solution. But I owe some credit to Pete for his coding solution above as well.

I need to work your code. into my file. I also plan to dissect both solutions (yours and Pete's) a bit as a learning exercise.

Thanks,

​

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.

 

[Lantern]

Not sure if this is proper forum etiquette, but I unmarked Akuini's code as the solution.

To be clear, it's my fault.

Akuini's code works great in my test sheet, but in my working parts list, the Y/N results column is two columns to the left of the Index column (not one column to the right).

In my coding attempts (which I did not get to fully work), after testing, it was easy to offset the results to whatever column needed in my working parts list. But now, I can't figure out a similar column offset solution that works with Akuini's eloquent code.

I hope there is an easy code adjustment for this.

Suggestions please.