Thread: Speeding up Array

Hi all,

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

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!

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" <gti_jobert.29c5an_1150193405.2815@excelforum-nospam.com> wrote
in message news:gti_jobert.29c5an_1150193405.2815@excelforum-nospam.com...
>
> 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
>

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.

--
Regards,
Tom Ogilvy


"gti_jobert" wrote:

>
> 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
>
>

Hi all,

Thanks for the replies...have used some of the code posted to speed it up - no problems with the Array speed now

Just one more question tho...

I need to find out the maximum value of Arry(5, 1 to maxArray) - I loop Week numbers in here. I have been trying to use excels Max function:

EndWeek = Application.Max(val1, val2) - this works when i try it for 2 values but how would I adapt it to feed my array values into it?

thanks again guys for help!

Simply loop through your array, for example

dim i as Long
dim lMax as Long

for i = 1 to maxArray
if Arry(1, i) > lMax then
lMax = Arry(1, i)
end if
next

RBS


gti_jobert wrote:
> Hi all,
>
> Thanks for the replies...have used some of the code posted to speed it
> up - no problems with the Array speed now
>
> Just one more question tho...
>
> I need to find out the maximum value of Arry(5, 1 to maxArray) - I loop
> Week numbers in here. I have been trying to use excels Max function:
>
> EndWeek = Application.Max(val1, val2) - this works when i try it for 2
> values but how would I adapt it to feed my array values into it?
>
> thanks again guys for help!
>
>
> --
> 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