Nested loops + concatenate values based on match

Sorry for the uninforming title.

My task is quite simple but I need this to be done in a macro (instead of filtering) and it has proven surprisingly difficult for me.

I have 3 columns (A,B,C) and an open-ended list of items (rows).
- A (category): gives the item's category (multiple items have the same category)
- B (value): item's value (text) which may not be unique among items
- C (selection): takes value TRUE or FALSE

I would need a macro that would report (separately for each category) the list of values taken by items that have been selected (i.e. for which column C equals TRUE). I would need the output to be a text string looking like this:

- Name of category 1: value1.1, value1.3, value1.5
- Name of category 2: value2.3
- Name of category 3: no item was selected for category 3

Here is a simplified example of my excel file Template.xlsx.

Many thanks!

PS: while the example has 3 different categories, this will vary in practice so the code should be robust to any number of categories ideally.

this should do it. File attached, code below. Make sure the sheet name is "Output"

Sub test()

Dim LastRow As Integer
Dim lastcolumn As Integer

Dim x As Integer

Dim iLoans As String
Dim pLoans As String
Dim pbLoans As String
Dim iCount As Integer
Dim pCount As Integer
Dim pbCount As Integer


iLoans = "Investment Loans: "
pLoans = "Policy Based Loans: "
pbLoans = "Program Based Loans: "


Sheets("Input").Select
LastRow = Range("a65000").End(xlUp).Row



iCount = 0
pCount = 0
pbCount = 0


For Each rcell In Range("A2", Cells(LastRow, 1))

    If rcell.Offset(0, 2).Value = "False" Then
    
    Else
    
        If rcell.Value = "Investment Loans" Then
    
            iCount = iCount + 1
            
            If iCount = 1 Then
                
                iLoans = iLoans & rcell.Offset(0, 1).Value
                
                Else
            
                iLoans = iLoans & ", " & rcell.Offset(0, 1).Value
            
            End If
                
        ElseIf rcell.Value = "Policy Based Loans" Then
        
            pCount = pCount + 1
            
            If pCount = 1 Then
                
                pLoans = pLoans & rcell.Offset(0, 1).Value
                
                Else
            
                pLoans = pLoans & ", " & rcell.Offset(0, 1).Value
            
            End If
                
        
        
        ElseIf rcell.Value = "Program Based Loans" Then
            
            pbCount = pbCount + 1
            
            If pbCount = 1 Then
                
                pbLoans = pbLoans & rcell.Offset(0, 1).Value
                
                Else
            
                pbLoans = pbLoans & ", " & rcell.Offset(0, 1).Value
            
            End If
            
            
        End If
        

    End If
    


Next rcell


Sheets("Output").Select

Range("a3").Value = iLoans
Range("a4").Value = pLoans
Range("A5").Value = pbLoans



End Sub

here you go

Hello olivierpbeland,

Ths attached workbook contains the macro below. The macro does not require the data to be grouped by category nor does it care how many there are. It automatically determines the unique number of categories and combines only like values that are marked true. The result is displayed on the worksheet "Output". A button has been added t0 the sheet to run the macro.

Sub ReportByCategory()

    Dim Category
    Dim Dict As Object
    Dim DstRng As Range
    Dim DstWks As Worksheet
    Dim n As Long
    Dim r As Long
    Dim RngEnd As Range
    Dim SrcRng As Range
    Dim SrcWks As Worksheet
    
        Set SrcWks = Worksheets("Input")
        Set DstWks = Worksheets("Output")
        
        Set SrcRng = SrcWks.Range("A2:C2")
        Set DstRng = DstWks.Range("A1")
        
            Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
            If RngEnd.Row < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcWks.Range(SrcRng, RngEnd)
            
            Set RngEnd = DstWks.Cells(Rows.Count, DstRng.Column).End(xlUp)
            If RngEnd.Row >= DstRng.Row Then DstWks.Range(DstRng, RngEnd).ClearContents
            
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
            
                For Each Cell In SrcRng.Columns(1).Cells
                    If Cell <> "" And Cell.Item(1, 3) = True Then
                        Category = Trim(Cell)
                        If Not Dict.Exists(Category) Then
                            Dict.Add Category, Cell.Item(1, 2).Value
                        Else
                            Data = Dict(Category) & ", " & Cell.Item(1, 2).Value
                            Dict(Category) = Data
                        End If
                    End If
                Next Cell
                
            Application.ScreenUpdating = False
            
                For Each Category In Dict.Keys
                    DstRng.Offset(r, 0) = Category & ": " & Dict(Category)
                    r = r + 1
                Next Category
                
            Application.ScreenUpdating = True
            
End Sub

another approach

Sub RowsToCell()
  Dim LR As Long, m As Long, k As Long, x As Long, res As String, y As Long
  LR = Cells(Rows.Count, 1).End(xlUp).Row
  k = 2: y = 2
    Do
      x = k
      m = Cells(k, 1).End(xlDown).Row
        res = Cells(x, 1).Value & ": "
          For x = k To m
            If Cells(x, 3) = True Then
              res = res & Cells(x, 2).Value & ", "
            End If
          Next x
          Sheets("Output").Cells(y, 1) = Left(res, Len(res) - 2)
          y = y + 1
        If m = LR Then Exit Sub
      k = m + 2
    Loop
End Sub