Transpose data.

[harzer]

Hello everyone,
I present to you my problem which I cannot solve given my level in VBA, I will explain the details to enable you to resolve it:
In my sheet "Sheet1" I have 5 groups, each group consists of 3 lines, sometimes more, in our case here all groups consist of three lines.
The group numbers are in column “A”.
For greater visibility of the different groups, I colored each group a different color.

If the subject sought (in column "F") is in the first line of the group, then the position will be "Position 1" = column "M", likewise, if the subject is in the 2nd line of the group, this means that the position will be "position 2" = column "N" and finally if the subject is in row 3, then the position will be "Position 3" = column "O".

The desired final result is in the range ("M2:O9"). Here is how we will proceed:
To begin, we will create a list without duplicates from all the elements of column "F" to place it in column "L".
To explain it to you better, we will take an example, here we go:
We go through the column "L" on all the cells that make it up from "L2" to "L9", the first cell encountered is "AE27-022/2022 M", we will look for the same value in column " F", we find it in cell "F2" and "F13":
F2: is located in the first line of our Group, therefore Position 1, we will retrieve the value of column "A" from the same line = (Group 1) which we will write in "M2".
F13: is located in the 3rd line of our Group, therefore Position 3, we will retrieve the value of column "A" from the same line = (Group 4) which we will write in "O2".

We continue with the next cell in column "L", this is cell "5919-001/2023 M", we find this value in "F3".
F3: is located in the 2nd line of our Group, therefore Position 2, we will retrieve the value of column "A" from the same line = (Group 1) which we will write in "N3"

We continue in the same way for all the cells in column “L” and look for matches in column “F” and “A”
Information: If we are faced with the possibility of having several pieces of information in the same cell, it would be desirable to separate the groups with a hyphen (-)
I hope I have been clear enough in my explanations, if necessary, I remain at your disposal.
Thank you for your propositions.

Classeur1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Groupes :	Female	Father	Mother		Male	Father	Mother				List Without duplicates	Position 1	Position 2	Position 3
2	Groupe 1	MN96-010/2021 F	MN96-002/2020 M	MN96-020/2020 F		AE27-022/2022 M	AE27-049/2021 M	AE27-003/2021 F				AE27-022/2022 M	Groupe 1		Groupe 4
3						5919-001/2023 M	3024-058/2020 M	3024-011/2022 F				5919-001/2023 M		Groupe 1
4												AE27-035/2022 M	Groupe 2
5	Groupe 2	MN96-034/2021 F	MN96-050/2020 M	MN96-013/2019 F		AE27-035/2022 M	MN96-005/2021 M	AE27-068/2021 F				AE27-069/2023 M	Groupe 3	Groupe 2
6						AE27-069/2023 M	AE27-018/2022 M	MN96-045/2022 F				MN96-008/2021 M			Groupe 2 - Groupe 3 - Groupe 5
7						MN96-008/2021 M	MN96-002/2020 M	MN96-020/2020 F				AE27-033/2022 M	Groupe 4	Groupe 4
8	Groupe 3	AE27-026/2022 F	MN96-046/2019 M	MN96-036/2021 F		AE27-069/2023 M	AE27-018/2022 M	MN96-045/2022 F				MN96-020/2023 M	Groupe 5
9						MN96-008/2021 M	MN96-002/2020 M	MN96-020/2020 F				AE27-010/2021 M		Groupe 5
10
11	Groupe 4	AE27-037/2022 F	MN96-005/2021 M	AE27-068/2021 F		AE27-033/2022 M	AE27-010/2021 M	MN96-034/2021 F
12						AE27-033/2022 M	AE27-010/2021 M	MN96-034/2021 F
13						AE27-022/2022 M	AE27-049/2021 M	AE27-003/2021 F
14	Groupe 5	AE27-038/2022 F	MN96-005/2021 M	AE27-068/2021 F		MN96-020/2023 M	MN96-011/2022 M	MN96-020/2021 F
15						AE27-010/2021 M	AE27-015/2020 M	AE27-021/2020 F
16						MN96-008/2021 M	MN96-002/2020 M	MN96-020/2020 F
Sheet1

 

[Cubist]

Try on a copy.

Sub FindGroup()
    Dim a, b, dict As Object, key As Variant
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim ws As Worksheet
    Dim numRow As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change sheet name as needed
    numRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    a = ws.Range("A2:I" & numRow).Value
    j = 1

    'Assign index
    For i = 1 To numRow - 1
        If a(i, 1) > 0 Then
            j = 1
            a(i, 9) = j
        Else
            j = j + 1
            a(i, 9) = j
        End If
    Next i
    
    ' Find max number of position
    Dim maxPos As Long
    maxPos = a(1, 9)
    For i = 1 To UBound(a, 1)
        If a(i, 9) > maxPos Then
            maxPos = a(i, 9)
        End If
    Next i
    'Fill in Groups
    For k = 1 To numRow - 1
        If k > 1 Then
            If a(k, 1) = "" Then a(k, 1) = a(k - 1, 1)
        End If
    Next k
    
    ' Create a dictionary object to store unique non-blank values from column F
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To numRow - 1
        If Not dict.exists(a(i, 6)) And a(i, 6) <> "" Then
            dict.Add a(i, 6), a(i, 6)
        End If
    Next i
 
    ReDim b(1 To dict.Count, 1 To maxPos + 1)
    i = 1
    For Each key In dict.Keys
        b(i, 1) = key
        i = i + 1
    Next key
    ' Concatenate values based on conditions
    For n = 1 To UBound(a, 1)
        For m = 1 To UBound(b, 1)
            If b(m, 1) = a(n, 6) Then
                If b(m, 1 + a(n, 9)) = "" Then
                    b(m, 1 + a(n, 9)) = a(n, 1)
                Else
                    b(m, 1 + a(n, 9)) = b(m, 1 + a(n, 9)) & "-" & a(n, 1)
                End If
            End If
        Next m
    Next n
    ' Output to sheet
    ws.Range("L2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[harzer]

Hello Cubist and the forum,
Thank you for your feedback, in fact, the code put in place works very, very well and very quickly, it completely satisfies me, Thank you very much.
May I allow myself to ask you one very last thing to close this project, namely to write the headers according to the number of existing positions, we will have the following representations:

If the position number is 3, then we will have this in the range "L1" to "O1":

demande MrExcel.xlsm
	L	M	N	O
1	List	Position 1	Position 2	Position 3
Sheet1

If the number of positions is 4, then we will have this in the range "L1" to "P1":

demande MrExcel.xlsm
	L	M	N	O	P
1	List	Position 1	Position 2	Position 3	Position 4
Sheet1

Thank you so much.
Friendships.

 

[Cubist]

How about

Sub FindGroup()
    Dim a, b, dict As Object, key As Variant, headers As Variant
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim ws As Worksheet
    Dim numRow As Long
  
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change sheet name as needed
    numRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    a = ws.Range("A2:I" & numRow).Value
    j = 1

    'Assign index
    For i = 1 To numRow - 1
        If a(i, 1) > 0 Then
            j = 1
            a(i, 9) = j
        Else
            j = j + 1
            a(i, 9) = j
        End If
    Next i
  
    ' Find max number of position
    Dim maxPos As Long
    maxPos = a(1, 9)
    For i = 1 To UBound(a, 1)
        If a(i, 9) > maxPos Then
            maxPos = a(i, 9)
        End If
    Next i
    'Fill in Groups
    For k = 1 To numRow - 1
        If k > 1 Then
            If a(k, 1) = "" Then a(k, 1) = a(k - 1, 1)
        End If
    Next k
  
    ' Create a dictionary object to store unique non-blank values from column F
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To numRow - 1
        If Not dict.exists(a(i, 6)) And a(i, 6) <> "" Then
            dict.Add a(i, 6), a(i, 6)
        End If
    Next i
 
    ReDim b(1 To dict.Count, 1 To maxPos + 1)
    i = 1
    For Each key In dict.Keys
        b(i, 1) = key
        i = i + 1
    Next key
    ' Concatenate values based on conditions
    For n = 1 To UBound(a, 1)
        For m = 1 To UBound(b, 1)
            If b(m, 1) = a(n, 6) Then
                If b(m, 1 + a(n, 9)) = "" Then
                    b(m, 1 + a(n, 9)) = a(n, 1)
                Else
                    b(m, 1 + a(n, 9)) = b(m, 1 + a(n, 9)) & "-" & a(n, 1)
                End If
            End If
        Next m
    Next n
  'headers
    ReDim headers(1 To 1, 1 To maxPos + 1)
  headers(1, 1) = "List"
   For i = 1 To maxPos
        headers(1, i + 1) = "Position " & i
  Next i

    ' Output to sheet
    ws.Range("L1").Resize(UBound(headers, 1), UBound(headers, 2)).Value = headers
    ws.Range("L2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

 

[harzer]

Hello Cubist and the Forum,
Thank you very much for updating the code as per my last request, the code works beautifully.
Bravo and thank you again for your support and availability.
Friendships.