Speeding up Array

gti_jobert · Jun 13, 2006

Hi all,

I have the following code that loop through a sheet and fills a
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 i
takes quite a long time.

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

Thanks for any input

RB Smissaert · Jun 13, 2006

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

Guest · Jun 13, 2006

this may be a little faster. If one had greater knowledge of your data, it
is possible it could be improved even more:

Sub ABC()
Dim rng As Range, rng1 As Range
Dim sAddr As String, j As Long
Dim MaxArray As Long, machine As String
Dim EndWeek As String
Dim Arry()
ReDim Arry(1 To 5, 1 To 1)
MaxArray = 0

Set rng = Range(Cells(1, 5), _
Cells(Rows.Count, 5).End(xlUp))
Set rng1 = rng.Find(What:="HDW-*", _
After:=rng(rng.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng1 Is Nothing Then
sAddr = rng1.Address
Do
machine = Mid(rng1.Value, 3, 1) & Right(rng.Value, 3)

j = rng1.Row + 7
Do
If Len(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) = Cells(j, 4).Value 'Batch
Arry(2, MaxArray) = Cells(j, 6).Value 'Part
Arry(4, MaxArray) = (Cells(j, 7).Value / 1000) 'Qty
Arry(5, MaxArray) = Left(Cells(j, 2).Value, 2) 'Week

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

End If
j = j + 1
Loop Until Cells(j, 2).Value = ""
Set rng1 = rng.FindNext(rng1)
Loop While rng1.Address <> sAddr
End If
End Sub

the logic here is slightly different than yours. If there are records
beginning with HDW- that occur after you would normally stop (test of WH24),
then this will process those as well. I assume that isn't the case.

You can use the same redim preserve statement you are using, but you will
only be able to remove data from the end of the array (in this case, the
upper part of the second dimension

redim preserve arry(1 to 5, 1 to Ubound(arry,2) - 1)

will remove the last set of values.

gti_jobert · Jun 13, 2006