vba to repeat a set of items based on list

[BORUCH]

Hi all

i have an excel sheet that looks like below

I would like an excel vba that would repeat column B AND C for each item in column E

My final results should like like below

Thanks

 

[lrobbo314]

Could do it using formulas.

Blank_2_Years (3).xlsx
	B	C	D	E	F	G	H	I
1	APPLES	123		A0001		A0001	APPLES	123
2	ORANGES	456		A0002		A0001	ORANGES	456
3	PEARS	789		A0003		A0001	PEARS	789
4	BANANAS	101112		A0004		A0001	BANANAS	101112
5				A0005		A0002	APPLES	123
6				A0006		A0002	ORANGES	456
7						A0002	PEARS	789
8						A0002	BANANAS	101112
9						A0003	APPLES	123
10						A0003	ORANGES	456
11						A0003	PEARS	789
12						A0003	BANANAS	101112
13						A0004	APPLES	123
14						A0004	ORANGES	456
15						A0004	PEARS	789
16						A0004	BANANAS	101112
17						A0005	APPLES	123
18						A0005	ORANGES	456
19						A0005	PEARS	789
20						A0005	BANANAS	101112
21						A0006	APPLES	123
22						A0006	ORANGES	456
23						A0006	PEARS	789
24						A0006	BANANAS	101112
Sheet2

Cell Formulas
Range	Formula
E1:E6	E1	="A"&TEXT(SEQUENCE(6),"0000")
G1:I24	G1	=LET(a,B1:B4,c,E1:E6,ra,ROWS(a),rt,ra*ROWS(c),ss,MOD(SEQUENCE(rt)-1,ra)+1,CHOOSE({1,2,3},INDEX(c,INT(SEQUENCE(rt,,,1/ra))),INDEX(a,ss),INDEX(C1:C4,ss)))
Dynamic array formulas.

 

[BORUCH]

Could do it using formulas.

Blank_2_Years (3).xlsx
	B	C	D	E	F	G	H	I
1	APPLES	123		A0001		A0001	APPLES	123
2	ORANGES	456		A0002		A0001	ORANGES	456
3	PEARS	789		A0003		A0001	PEARS	789
4	BANANAS	101112		A0004		A0001	BANANAS	101112
5				A0005		A0002	APPLES	123
6				A0006		A0002	ORANGES	456
7						A0002	PEARS	789
8						A0002	BANANAS	101112
9						A0003	APPLES	123
10						A0003	ORANGES	456
11						A0003	PEARS	789
12						A0003	BANANAS	101112
13						A0004	APPLES	123
14						A0004	ORANGES	456
15						A0004	PEARS	789
16						A0004	BANANAS	101112
17						A0005	APPLES	123
18						A0005	ORANGES	456
19						A0005	PEARS	789
20						A0005	BANANAS	101112
21						A0006	APPLES	123
22						A0006	ORANGES	456
23						A0006	PEARS	789
24						A0006	BANANAS	101112
Sheet2

Cell Formulas
Range	Formula
E1:E6	E1	="A"&TEXT(SEQUENCE(6),"0000")
G1:I24	G1	=LET(a,B1:B4,c,E1:E6,ra,ROWS(a),rt,ra*ROWS(c),ss,MOD(SEQUENCE(rt)-1,ra)+1,CHOOSE({1,2,3},INDEX(c,INT(SEQUENCE(rt,,,1/ra))),INDEX(a,ss),INDEX(C1:C4,ss)))
Dynamic array formulas.

i would rather use vba

 

[lrobbo314]

Blank_2_Years (3).xlsx
	B	C	D	E	F	G	H	I
1	APPLES	123		A0001		A0001	APPLES	123
2	ORANGES	456		A0002		A0001	ORANGES	456
3	PEARS	789		A0003		A0001	PEARS	789
4	BANANAS	101112		A0004		A0001	BANANAS	101112
5				A0005		A0002	APPLES	123
6				A0006		A0002	ORANGES	456
7						A0002	PEARS	789
8						A0002	BANANAS	101112
9						A0003	APPLES	123
10						A0003	ORANGES	456
11						A0003	PEARS	789
12						A0003	BANANAS	101112
13						A0004	APPLES	123
14						A0004	ORANGES	456
15						A0004	PEARS	789
16						A0004	BANANAS	101112
17						A0005	APPLES	123
18						A0005	ORANGES	456
19						A0005	PEARS	789
20						A0005	BANANAS	101112
21						A0006	APPLES	123
22						A0006	ORANGES	456
23						A0006	PEARS	789
24						A0006	BANANAS	101112
Sheet2

Sub CMBO()
Dim AR1() As Variant:       AR1 = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value2
Dim AR2() As Variant:       AR2 = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).Value2
Dim r As Range:             Set r = Range("G1")

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR2)
        For j = 1 To UBound(AR1)
            .Add AR2(i, 1) & ";" & AR1(j, 1) & ";" & AR1(j, 2)
        Next j
    Next i
    Set r = r.Resize(.Count)
    r.Value2 = Application.Transpose(.toArray)
    r.TextToColumns DataType:=xlDelimited, Semicolon:=True
End With

End Sub

 

[BORUCH]

Blank_2_Years (3).xlsx
	B	C	D	E	F	G	H	I
1	APPLES	123		A0001		A0001	APPLES	123
2	ORANGES	456		A0002		A0001	ORANGES	456
3	PEARS	789		A0003		A0001	PEARS	789
4	BANANAS	101112		A0004		A0001	BANANAS	101112
5				A0005		A0002	APPLES	123
6				A0006		A0002	ORANGES	456
7						A0002	PEARS	789
8						A0002	BANANAS	101112
9						A0003	APPLES	123
10						A0003	ORANGES	456
11						A0003	PEARS	789
12						A0003	BANANAS	101112
13						A0004	APPLES	123
14						A0004	ORANGES	456
15						A0004	PEARS	789
16						A0004	BANANAS	101112
17						A0005	APPLES	123
18						A0005	ORANGES	456
19						A0005	PEARS	789
20						A0005	BANANAS	101112
21						A0006	APPLES	123
22						A0006	ORANGES	456
23						A0006	PEARS	789
24						A0006	BANANAS	101112
Sheet2

Sub CMBO()
Dim AR1() As Variant:       AR1 = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value2
Dim AR2() As Variant:       AR2 = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).Value2
Dim r As Range:             Set r = Range("G1")

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR2)
        For j = 1 To UBound(AR1)
            .Add AR2(i, 1) & ";" & AR1(j, 1) & ";" & AR1(j, 2)
        Next j
    Next i
    Set r = r.Resize(.Count)
    r.Value2 = Application.Transpose(.toArray)
    r.TextToColumns DataType:=xlDelimited, Semicolon:=True
End With

End Sub

Thanks you very much, just one thing if you can add please it doesn't work if there is only one value in column E there needs to be more for it to work
#2 if the value in column E would cause a duplicate in column G it should do nothing, For ex if in column e you have two entries of A01 it should only do it once.

Thanks

 

[lrobbo314]

How about this?

Sub CMBO()
Dim r As Range:             Set r = Range("G1")
Dim er As Range:            Set er = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR1() As Variant:       AR1 = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value2
Dim AR2() As Variant
Dim SD As Object:           Set SD = CreateObject("Scripting.Dictionary")

If er.Cells.Count = 1 Then
    ReDim AR2(1 To 1, 1 To 1)
    AR2(1, 1) = er.Value2
Else
    AR2 = er.Value2
End If

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR2)
        If Not SD.exists(AR2(i, 1)) Then
            SD.Add (AR2(i, 1)), 1
            For j = 1 To UBound(AR1)
                .Add Join(Array(AR2(i, 1), AR1(j, 1), AR1(j, 2)), ";")
            Next j
        End If
    Next i
    Set r = r.Resize(.Count)
    r.Value2 = Application.Transpose(.toArray)
    r.TextToColumns DataType:=xlDelimited, Semicolon:=True
End With

End Sub

 

[BORUCH]

How about this?

Sub CMBO()
Dim r As Range:             Set r = Range("G1")
Dim er As Range:            Set er = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR1() As Variant:       AR1 = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value2
Dim AR2() As Variant
Dim SD As Object:           Set SD = CreateObject("Scripting.Dictionary")

If er.Cells.Count = 1 Then
    ReDim AR2(1 To 1, 1 To 1)
    AR2(1, 1) = er.Value2
Else
    AR2 = er.Value2
End If

With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(AR2)
        If Not SD.exists(AR2(i, 1)) Then
            SD.Add (AR2(i, 1)), 1
            For j = 1 To UBound(AR1)
                .Add Join(Array(AR2(i, 1), AR1(j, 1), AR1(j, 2)), ";")
            Next j
        End If
    Next i
    Set r = r.Resize(.Count)
    r.Value2 = Application.Transpose(.toArray)
    r.TextToColumns DataType:=xlDelimited, Semicolon:=True
End With

End Sub

Thank you very much that worked