Find a subject that is in column "P" in columns "G" and "L" and export.

[harzer]

Hello everyone,
Given my level in VBA, it is impossible for me to come up with a solution, hence my request to the Experts among you to help me, I would like to ask you for a solution with UBound, or with dictionary, or both combined, because the data to be processed is numerous.
Here is the problem:
I need to go through all the cells in column "P" and see if I find identical cells in column "G" and "L".
We start with the cell in "P2", the value of cell "P2" = "3024-066/2020 M", when the cell in column "G" is equal to the value of cell "P2", we export the value of the cell of column "F" in column "Q" and that of column "H" in column "R" and continues thus until the end of column "G".
When the search in column "G" is completed, we will continue the search in column "L" from "L2" to the last line.
When this step is completed, we will do the same for the cell located in “P3”

Initial sheet:

Classeur1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1						Sujets	Parents	nombre	générations		Sujets	Parents	nombre	générations		Parents
2						3024-060/2023 M	3024-066/2020 M	2	G1		27-009/2023 F	CT10-075/2005 M	95	G41		3024-066/2020 M
3						3024-0555/2023 M	2207-032/2020 F	5	G1		27-010/2023 F	SC14-020/2005 F	95	G5		2207-032/2020 F
4						3024-073/2023 M	392-019/2018 M	9	G2		27-004/2023 F	235-096/2005 M	70	G9		392-019/2018 M
5						5919-089/2023 M	3024-066/2020 M	15	G3		27-055/2023 F	03-001/2010 F	26	G2		3024-011/2022 F
6						5919-001/2023 M	3024-011/2022 F	1	G4		27-009/2023 F	838-017/2008 M	26	G8		5617-061/2019 F
7						5919-002/2023 M	5617-061/2019 F	50	G3		27-009/2023 F	SC14-019/2006 F	25	G6		SC14-020/2005 F
8						27-010/2021 M	3024-066/2020 M	48	G4		27-009/2023 F	3024-066/2020 M	24	G14		235-096/2005 M
9						27-013/2021 M	SC14-020/2005 F	48	G11		27-009/2023 F	SC14-018/2008 F	24	G6		SC14-068/2006 M
10						27-010/2021 M	235-096/2005 M	35	G4		27-009/2023 F	SC14-045/2004 M	24	G3		856-062/2009 M
11						27-015/2021 M	SC14-068/2006 M	30	G10		27-009/2023 F	SC14-009/2004 F	24	G9		856-148/2007 M
12						27-023/2021 M	856-062/2009 M	29	G4		27-009/2023 F	856-062/2009 M	22	G8		03*-156/2011 M
13						27-077/2021 M	856-148/2007 M	28	G20		27-009/2023 F	856-131/2011 F	19	G1		856-090/2010 M
14						27-055/2021 M	03*-156/2011 M	18	G5		27-009/2023 F	3024-066/2020 M	19	G18		CT10-075/2005 M
15						27-041/2021 M	856-090/2010 M	18	G6		27-009/2023 F	856-071/2007 F	19	G30		03-001/2010 F
16						27-010/2021 M	2207-032/2020 F	18	G10		27-009/2023 F	3024-066/2020 M	16	G9		838-017/2008 M
17											27-009/2023 F	2207-032/2020 F	55	G13		SC14-019/2006 F
18																SC14-018/2008 F
19																SC14-045/2004 M
20																SC14-009/2004 F
21																856-131/2011 F
22																856-071/2007 F
Anc_Communs

Unless I'm mistaken, here is the sheet with the desired result (For the first subject which is in cell "P2").

Classeur1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1						Sujets	Parents	nombre	générations		Sujets	Parents	nombre	générations		Parents
2						3024-060/2023 M	3024-066/2020 M	2	G1		27-009/2023 F	CT10-075/2005 M	95	G41		3024-066/2020 M	3024-060/2023 M	2	5919-089/2023 M	15	27-010/2021 M	48	27-009/2023 F	24	27-009/2023 F	19	27-009/2023 F	16
3						3024-0555/2023 M	2207-032/2020 F	5	G1		27-010/2023 F	SC14-020/2005 F	95	G5		2207-032/2020 F
4						3024-073/2023 M	392-019/2018 M	9	G2		27-004/2023 F	235-096/2005 M	70	G9		392-019/2018 M
5						5919-089/2023 M	3024-066/2020 M	15	G3		27-055/2023 F	03-001/2010 F	26	G2		3024-011/2022 F
6						5919-001/2023 M	3024-011/2022 F	1	G4		27-009/2023 F	838-017/2008 M	26	G8		5617-061/2019 F
7						5919-002/2023 M	5617-061/2019 F	50	G3		27-009/2023 F	SC14-019/2006 F	25	G6		SC14-020/2005 F
8						27-010/2021 M	3024-066/2020 M	48	G4		27-009/2023 F	3024-066/2020 M	24	G14		235-096/2005 M
9						27-013/2021 M	SC14-020/2005 F	48	G11		27-009/2023 F	SC14-018/2008 F	24	G6		SC14-068/2006 M
10						27-010/2021 M	235-096/2005 M	35	G4		27-009/2023 F	SC14-045/2004 M	24	G3		856-062/2009 M
11						27-015/2021 M	SC14-068/2006 M	30	G10		27-009/2023 F	SC14-009/2004 F	24	G9		856-148/2007 M
12						27-023/2021 M	856-062/2009 M	29	G4		27-009/2023 F	856-062/2009 M	22	G8		03*-156/2011 M
13						27-077/2021 M	856-148/2007 M	28	G20		27-009/2023 F	856-131/2011 F	19	G1		856-090/2010 M
14						27-055/2021 M	03*-156/2011 M	18	G5		27-009/2023 F	3024-066/2020 M	19	G18		CT10-075/2005 M
15						27-041/2021 M	856-090/2010 M	18	G6		27-009/2023 F	856-071/2007 F	19	G30		03-001/2010 F
16						27-010/2021 M	2207-032/2020 F	18	G10		27-009/2023 F	3024-066/2020 M	16	G9		838-017/2008 M
17											27-009/2023 F	2207-032/2020 F	55	G13		SC14-019/2006 F
18																SC14-018/2008 F
19																SC14-045/2004 M
20																SC14-009/2004 F
21																856-131/2011 F
22																856-071/2007 F
Résultat

I remain at your disposal for further information.
I thank you in advance for your suggestions.

 

[dermie_72]

See if this works for you:

Sub harzer()

Dim LR, LR1, LR2, LC, A, B, C As Long
Dim Chk As String

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False

LR = Cells(Rows.count, "P").End(xlUp).Row
LR1 = Cells(Rows.count, "G").End(xlUp).Row
LR2 = Cells(Rows.count, "L").End(xlUp).Row

For A = 2 To LR
    Chk = Range("P" & A).Value
    For B = 2 To LR1
        If Range("G" & B).Value = Chk Then
            LC = Cells(A, Columns.count).End(xlToLeft).Column + 1
            Cells(A, LC).Value = Range("F" & B).Value
            Cells(A, LC + 1).Value = Range("H" & B).Value
            Else
        End If
    Next B
    For C = 2 To LR2
        If Range("L" & C).Value = Chk Then
            LC = Cells(A, Columns.count).End(xlToLeft).Column + 1
            Cells(A, LC).Value = Range("K" & C).Value
            Cells(A, LC + 1).Value = Range("M" & C).Value
            Else
        End If
    Next C
Next A

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

 

[harzer]

Hello dermie_72,
Thanks for your code.
I just initialized the "Lc" variable twice by writing Lc = 1 so that the program gives me the desired result.
I tested your code with my data, it works fine and gives me the desired result, however, it takes a while to run, hence my request to use arrays (UBound) as I know they are very fast.
I would be happy if you know how to adapt your code using arrays (UBound).
Greetings.

Sub harzer()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False


lr = Cells(Rows.count, "P").End(xlUp).row
LR1 = Cells(Rows.count, "G").End(xlUp).row
LR2 = Cells(Rows.count, "L").End(xlUp).row

For a = 2 To lr
lc = 1                        'I added this line to make the code work the way I want.                                
    Chk = Range("P" & a).Value
    For b = 2 To LR1
        If Range("G" & b).Value = Chk Then
            lc = Cells(a, Columns.count).End(xlToLeft).Column + 1
            Cells(a, lc).Value = Range("F" & b).Value
            Cells(a, lc + 1).Value = Range("H" & b).Value
            Else
        End If
    Next b
    
lc = 1                        'I added this line to make the code work the way I want.
    For c = 2 To LR2
        If Range("L" & c).Value = Chk Then
            lc = Cells(a, Columns.count).End(xlToLeft).Column + 1
            Cells(a, lc).Value = Range("K" & c).Value
            Cells(a, lc + 1).Value = Range("M" & c).Value
            Else
        End If
    Next c
Next a

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub