VBA Codes to speed up nested loops (to generate 130.000+ rows)

[Ayra88]

Dear VBA experts,

I'm quite a beginner at VBA and am trying to solve a task at work. I did solve the task with VBA - but my codes needed more than 2 hours to generate the required result, which is 130.000+ rows * 50+ columns

I will try to demonstrate my task in a simplified example as follow:

We have 3 worksheets to begin with - A, B, C

Worksheet A

Worksheet B

Worksheet C

We want to generate this in worksheet ABC:
- for each row in Worksheet A copy and paste all rows in worksheet B
- then fill column F in Worksheet ABC with fixed value 1
- then fill column E in Worksheet ABX with a formula (Xlookup)

This is the code that I wrote:
Sub CopyAndLookUP()
arows = Sheets("A").Cells(Rows.Count, 1).End(xlUp).Row
brows = Sheets("B").Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Integer
i = 2
For x = 2 To arows:
name1 = Sheets("A").Cells(X, 1).Value
age = Sheets("A").Cells(X, 2).Value
For y = 2 To brows:
fruits = Sheets("B").Cells(y, 1).Value
color1 = Sheets("B").Cells(y, 2).Value

'copy and paste
Sheets("ABC").Cells(i, 1) = name1
Sheets("ABC").Cells(i, 2) = fruits
Sheets("ABC").Cells(i, 3) = age
Sheets("ABC").Cells(i, 4) = Color

'fill column F with fix value
Sheets("ABC").Cells(i, 6) = "1"

'fill column E with formula
Sheets("ABC").Cells(i, 5).FormulaR1C1 = "=IFERROR(XLOOKUP(RC[-4]&RC[-3],C!C[-4],C!C[-3]),"""")"
i = i + 1
Next y
Next x

End Sub

This is the result I achieved: (the green columns are from A and yellow columns are from B)

Now as I mentioned above, this code worked fine in this example, but it takes forever for my real life task (in which I dim I as Long in stead of Integer).
I suppose there must be a trick to make this all faster, could anyone please help me?

Thank you very much in advance!

Best

 

[Fluff]

How about

Sub Ayra()
   Dim Aary As Variant, Bary As Variant, Oary As Variant
   Dim r As Long, rr As Long, nr As Long
   
   With Sheets("A")
      Aary = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   With Sheets("B")
      Bary = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   ReDim Oary(1 To UBound(Aary) * UBound(Bary), 1 To 6)
   
   For r = 1 To UBound(Aary)
      For rr = 1 To UBound(Bary)
         nr = nr + 1
         Oary(nr, 1) = Aary(r, 1)
         Oary(nr, 2) = Bary(rr, 1)
         Oary(nr, 3) = Aary(r, 2)
         Oary(nr, 4) = Bary(rr, 2)
         Oary(nr, 6) = 1
      Next rr
   Next r
   With Sheets("ABC")
      .Range("A2").Resize(nr, 6).Value = Oary
      .Range("E2").Resize(nr).FormulaR1C1 = "=XLOOKUP(RC[-4]&RC[-3],C!R2C[-4]:R" & nr & "C[-4],C!R2C[-3]:R" & nr & "C[-3],"""",0)"
   End With
End Sub