For-Next loop really slow, can I use an array instead?

[TheWennerWoman]

Hello, this is a small subset of the code I am using which is taking forever to loop through 74,000 records (the full code has a lot more bits to it).

Sub create_journal()
Dim LastRow As Long
Dim a As Long
Dim b As Long

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
b = 2
For a = 2 To LastRow
Sheet2.Range("A" & b).Value = "C5678"
Sheet2.Range("B" & b).Value = "103000"
Sheet2.Range("C" & b).Value = Range("C" & a).Value
Sheet2.Range("D" & b).Value = Range("B" & a).Value
b = b + 1
If Range("D" & a).Value <> 0 Then
    Sheet2.Range("A" & b).Value = Range("A" & a).Value
    Sheet2.Range("B" & b).Value = "145444"
    Sheet2.Range("C" & b).Value = Range("D" & a).Value
    Sheet2.Range("D" & b).Value = Range("B" & a).Value
    b = b + 1
End If
If Range("E" & a).Value <> 0 Then
    Sheet2.Range("A" & b).Value = Range("A" & a).Value
    Sheet2.Range("B" & b).Value = "173000"
    Sheet2.Range("C" & b).Value = Range("E" & a).Value
    Sheet2.Range("D" & b).Value = Range("B" & a).Value
    b = b + 1
End If
If Range("F" & a).Value <> 0 Then
    Sheet2.Range("A" & b).Value = Range("A" & a).Value
    Sheet2.Range("B" & b).Value = "199000"
    Sheet2.Range("C" & b).Value = Range("F" & a).Value
    Sheet2.Range("D" & b).Value = Range("B" & a).Value
    b = b + 1
End If
If Range("G" & a).Value <> 0 Then
    Sheet2.Range("A" & b).Value = Range("A" & a).Value
    Sheet2.Range("B" & b).Value = "212000"
    Sheet2.Range("C" & b).Value = Range("G" & a).Value
    Sheet2.Range("D" & b).Value = Range("B" & a).Value
    b = b + 1
End If
If Range("H" & a).Value <> 0 Then
    Sheet2.Range("A" & b).Value = Range("A" & a).Value
    Sheet2.Range("B" & b).Value = "255666"
    Sheet2.Range("C" & b).Value = Range("H" & a).Value
    Sheet2.Range("D" & b).Value = Range("B" & a).Value
    b = b + 1
End If
Next

End Sub

How would I go about maybe reading this into an array and tghen just writing back once?

Thank you for reading.

 

[Peter_SSs]

It would be helpful to see (with XL2BB) say 5-10 rows of dummy sample data for the 'active sheet' from columns A:H

 

[Alex Blakenburg]

See if this works for you (on a copy of your workbook)

Sub create_journal_arr()
Dim LastRow As Long
Dim a As Long
Dim b As Long
Dim arrA As Variant, arrB As Variant
Dim wsA As Worksheet
Dim rngA As Range, rngB As Range

Set wsA = ActiveSheet
With wsA
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rngA = .Range(.Cells(2, "A"), .Cells(LastRow, "H"))
    arrA = rngA.Value2
End With

Set rngB = Sheet2.Range("A2")
ReDim arrB(1 To UBound(arrA) * 7, 1 To 4)

b = 1
For a = 1 To UBound(arrA)
arrB(b, 1) = "C5678"
arrB(b, 2) = "103000"
arrB(b, 3) = arrA(a, 3)
arrB(b, 4) = arrA(a, 2)
b = b + 1

If arrA(a, 4) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "145444"
    arrB(b, 3) = arrA(a, 4)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 5) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "173000"
    arrB(b, 3) = arrA(a, 5)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 6) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "199000"
    arrB(b, 3) = arrA(a, 6)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 7) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "212000"
    arrB(b, 3) = arrA(a, 7)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 8) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "255666"
    arrB(b, 3) = arrA(a, 8)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
Next

' Write out Array
rngB.Resize(b, UBound(arrB, 2)).Value = arrB

End Sub

 

[TheWennerWoman]

It would be helpful to see (with XL2BB) say 5-10 rows of dummy sample data for the 'active sheet' from columns A:H

Book2
	A	B	C	D	E	F	G	H
1	Site	Employee	Total	Type 1	Type 2	Type 3	Type 4	Type 5
2	X00001	ZV0001	100	28	20	19	20	13
3	X00002	ZV0002	90	17	19	27	16	11
4	X00003	ZV0003	80	15	10	32	14	9
5	X00004	ZV0004	70	13	27	10	12	8
6	X00005	ZV0005	60	11	21	10	10	8
7	X00006	ZV0006	50	9	9	17	8	7
8	X00007	ZV0007	40	7	22	0	6	5
9	X00008	ZV0008	30	5	7	9	5	4
10	X00009	ZV0009	20	3	5	9	0	3
11	X00010	ZV0010	10	1	6	0	2	1
Sheet1

 

[TheWennerWoman]

See if this works for you (on a copy of your workbook)

Sub create_journal_arr()
Dim LastRow As Long
Dim a As Long
Dim b As Long
Dim arrA As Variant, arrB As Variant
Dim wsA As Worksheet
Dim rngA As Range, rngB As Range

Set wsA = ActiveSheet
With wsA
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set rngA = .Range(.Cells(2, "A"), .Cells(LastRow, "H"))
    arrA = rngA.Value2
End With

Set rngB = Sheet2.Range("A2")
ReDim arrB(1 To UBound(arrA) * 7, 1 To 4)

b = 1
For a = 1 To UBound(arrA)
arrB(b, 1) = "C5678"
arrB(b, 2) = "103000"
arrB(b, 3) = arrA(a, 3)
arrB(b, 4) = arrA(a, 2)
b = b + 1

If arrA(a, 4) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "145444"
    arrB(b, 3) = arrA(a, 4)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 5) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "173000"
    arrB(b, 3) = arrA(a, 5)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 6) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "199000"
    arrB(b, 3) = arrA(a, 6)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 7) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "212000"
    arrB(b, 3) = arrA(a, 7)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
If arrA(a, 8) <> 0 Then
    arrB(b, 1) = arrA(a, 1)
    arrB(b, 2) = "255666"
    arrB(b, 3) = arrA(a, 8)
    arrB(b, 4) = arrA(a, 2)
    b = b + 1
End If
Next

' Write out Array
rngB.Resize(b, UBound(arrB, 2)).Value = arrB

End Sub

That works perfectly, and on a sample dataset of 35000 records was almost instant.

Many, many thanks.

The efficiency of arrays is much underestimated

 

[Alex Blakenburg]

Thanks for letting us know. Glad we could help.