It is slow for 2 reasons:
Selecting ranges, always try to avoid this.
Doing repeatedly ReDim Preserve. This will internally do a full array copy
everytime and that
slows things down.
Not sure it makes difference in speed here, but it is always better to
declare your variables.
To be forced to do this always put Option Explicit at the top of your
modules. Do in the VB editor:
Tools, Options, Editor, Require variable declaration.

Haven't tested, and it will need some editing, but something like this will
be much faster:


Sub test()

Dim i As Long
Dim j As Long
Dim c As Long
Dim LR As Long
Dim LR2 As Long
Dim arr
Dim arr2
Dim arr3

LR = Cells(65536, 5).End(xlUp).Row

arr = Range(Cells(5), Cells(LR, 5))

For i = 1 To UBound(arr)
If Mid(arr(i, 1), 3, 1) & Right(arr(i, 1), 3) = "WH24" Then
LR2 = i
Exit For
End If
Next

arr2 = Range(Cells(2), Cells(LR2, 7))
ReDim arr3(1 To 5, 1 To LR2)

For i = 1 To LR2

If Left(arr2(i, 4), 4) = "HDW-" Then

j = i + 7

Do
If Len(arr(j, 3)) = 9 Then
c = c + 1
arr3(1, c) = Mid(arr(i, 4), 3, 1) & Right(arr(i, 4), 3)
'machine
arr3(2, c) = arr2(j, 5).Value 'Part
arr3(3, c) = arr2(j, 3).Value 'Batch
arr3(4, c) = (arr2(j, 6).Value / 1000) 'Qty
arr3(5, c) = Left(arr2(j, 1), 2) 'Week
End If
j = j + 1
Loop Until Len(arr2(j, 1)) = 0

End If

Next

End Sub


Note that the final array is bigger (more columns) then needed, but that
shouldn't be a problem.


RBS



"gti_jobert" wrote
in message ...

Hi all,

I have the following code that loop through a sheet and fills an
Array;


Code:
--------------------

i = 1
Do
ActiveSheet.Cells(i, 5).Select
If Left(ActiveCell.Value, 4) = "HDW-" Then
machine = Mid(ActiveCell.Value, 3, 1) & Right(ActiveCell.Value, 3)
j = i + 7
Do
If Len(ActiveSheet.Cells(j, 4).Value) = 9 Then

maxArray = maxArray + 1
ReDim Preserve Arry(1 To 5, 1 To maxArray)

Arry(1, maxArray) = machine
Arry(3, maxArray) = ActiveSheet.Cells(j, 4).Value 'Batch
Arry(2, maxArray) = ActiveSheet.Cells(j, 6).Value 'Part
Arry(4, maxArray) = (ActiveSheet.Cells(j, 7).Value / 1000) 'Qty
Arry(5, maxArray) = Left(ActiveSheet.Cells(j, 2).Value, 2) 'Week

EndWeek = Left(ActiveSheet.Cells(j, 2).Value, 2)

End If
j = j + 1
Loop Until ActiveSheet.Cells(j, 2).Value = ""
End If
i = i + 1
Loop Until Mid(ActiveCell.Value, 3, 1) & Right(ActiveCell.Value, 3) =
"WH24"

--------------------


The problem I have is when I try to loop my values out of the array it
takes quite a long time.

How can I delete an Array value? I know I have to use Ubound or
something but I dont fully understand how it works!

Thanks for any input!


--
gti_jobert
------------------------------------------------------------------------
gti_jobert's Profile:
http://www.excelforum.com/member.php...o&userid=30634
View this thread: http://www.excelforum.com/showthread...hreadid=551341