Loop is slow trying array code

  • Thread starter Thread starter L. Howard
  • Start date Start date
L

L. Howard

The first macro works okay except it takes about 4 to 5 seconds to run on 2000 +/- rows.

I'm wanting to adapt Garry's array code, below the first, and take a named range do my little For Each statement to each cell/element. I plugged in the range naming line, hope it is correct.

I presume this will be much faster than the loop I wrote.

Thanks.
Howard

The data starts out like this all in column A, where the ABCDEnum 'belongs' to the P-num just above it. Lots of P-num's values have no ABCDEnum's and then are ignored.

P-4352
P-3534
P-4568
ABCDE123
P-4568
ABCDE124
P-4568
ABCDE125

And ends up like this in column A and B

P-4352
P-3534
P-4568 ABCDE123
P-3534
P-4568 ABCDE124
P-3534
P-4568 ABCDE125


Sub MyScan()

Dim lr As Long
Dim c As Range
Dim Rscan As Range

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 1).End(xlUp).row
Set Rscan = Range("A2:A" & lr)

For Each c In Rscan
If Left(c, 1) <> "P" Then
c.Cut c.Offset(-1, 1)
End If
Next

Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub



Sub GarryScan()
Dim v, vaMyVals(), iIncr%, RngRefs As Range

Range("A2").Select
Set RngRefs = Range(ActiveCell.Address, ActiveCell.Offset.End(xlDown).Address)

For Each v In Split(Range("Rngrefs").Value, ",")
ReDim Preserve vaMyVals(iIncr)
vaMyVals(iIncr) = Range(v).Value
iIncr = iIncr + 1
Next 'v
'Dump the array into the target sheet
'...
End Sub
 
Hi Howard,

Am Fri, 21 Feb 2014 00:02:18 -0800 (PST) schrieb L. Howard:
The first macro works okay except it takes about 4 to 5 seconds to run on 2000 +/- rows.

I'm wanting to adapt Garry's array code, below the first, and take a named range do my little For Each statement to each cell/element. I plugged in the range naming line, hope it is correct.

I presume this will be much faster than the loop I wrote.
Click to expand...

column B is empty? Then try:

Sub MyScan2()
Dim LRow As Long
Dim myArr As Variant
Dim i As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
myArr = Range("A2:B" & LRow)
For i = LBound(myArr) To UBound(myArr)
If Left(myArr(i, 1), 1) <> "P" Then
myArr(i - 1, 2) = myArr(i, 1)
myArr(i, 1) = ""
End If
Next
Range("A2:B" & LRow).ClearContents
Range("A2:B" & UBound(myArr)) = myArr
Range("A2:A" & LRow).SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete
End Sub


Regards
Claus B.
 
Hi Howard,



Am Fri, 21 Feb 2014 00:02:18 -0800 (PST) schrieb L. Howard:






column B is empty? Then try:



Sub MyScan2()

Dim LRow As Long

Dim myArr As Variant

Dim i As Long



LRow = Cells(Rows.Count, 1).End(xlUp).Row

myArr = Range("A2:B" & LRow)

For i = LBound(myArr) To UBound(myArr)

If Left(myArr(i, 1), 1) <> "P" Then

myArr(i - 1, 2) = myArr(i, 1)

myArr(i, 1) = ""

End If

Next

Range("A2:B" & LRow).ClearContents

Range("A2:B" & UBound(myArr)) = myArr

Range("A2:A" & LRow).SpecialCells(xlCellTypeBlanks) _

.EntireRow.Delete

End Sub





Regards

Claus B.

--
Click to expand...

4000 rows in about 1 second!

Thanks a bunch.

Regards,
Howard
 
Hi Howard,

Am Fri, 21 Feb 2014 01:16:31 -0800 (PST) schrieb L. Howard:
4000 rows in about 1 second!
Click to expand...

so you start the output in row 2 change the output range:
Range("A2:B" & UBound(myArr) + 1) = myArr
^^^^^^


Regards
Claus B.
 
Hi Howard,

Am Fri, 21 Feb 2014 01:16:31 -0800 (PST) schrieb L. Howard:
4000 rows in about 1 second!
Click to expand...

most of the time is needed to delete the blank rows.
If the order of occurence doesn't matter you could sort Range("A1:B" &
lrow) to eliminate the blank rows.


Regards
Claus B.
 
Hi Howard,

Am Fri, 21 Feb 2014 01:16:31 -0800 (PST) schrieb L. Howard:
4000 rows in about 1 second!
Click to expand...

a little bit faster. 10000 rows in 0.955 sec:

Sub MyScan3()
Dim LRow As Long
Dim myArr As Variant
Dim i As Long, j As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
myArr = Range("A2:B" & LRow)
For i = LBound(myArr) To UBound(myArr)
If Left(myArr(i, 1), 1) <> "P" Then
myArr(i - 1, 2) = myArr(i, 1)
myArr(i, 1) = ""
End If
Next

Range("A2:B" & LRow).ClearContents
j = 2
For i = LBound(myArr) To UBound(myArr)
If myArr(i, 1) <> "" Then
Cells(j, 1) = myArr(i, 1)
Cells(j, 2) = myArr(i, 2)
j = j + 1
End If
Next
End Sub


Regards
Claus B.
 
column B is empty? Then try:

Yes, column B starts off empty, forgot to respond to that.

If you don't mind, I'd like to read this portion back to you and see if I understand it.

This is pretty much the same as For Each C in Range.
For i = LBound(myArr) To UBound(myArr)
Click to expand...

This is looking to see if the first char of element number i is a "P".
I can't account for both 1's here.
=Left(Text, 1) on the sheet would be =Left(A1,1) = P.
So here it looks like =Left(The text for element i, 1 char) = P except there are two 1's.
If Left(myArr(i, 1), 1) <> "P" Then
Click to expand...

This is the offset of minus 1 row and 1 column right
myArr(i - 1, 2) = myArr(i, 1)
Click to expand...

This clears the A column cell, where I presume there is no 'Cut' available in an array, so that cell is still occupied until cleared.
myArr(i, 1) = ""
Click to expand...

This clears both A and B columns.
Range("A2:B" & LRow).ClearContents
Click to expand...


This puts all the new data back into columns A and B. So if the columns were cleared one step ago why would you run another Entire.Delete Row?
Range("A2:B" & UBound(myArr)) = myArr
Click to expand...


For i = LBound(myArr) To UBound(myArr)
If Left(myArr(i, 1), 1) <> "P" Then
myArr(i - 1, 2) = myArr(i, 1)
myArr(i, 1) = ""
End If
Next
Range("A2:B" & LRow).ClearContents
Range("A2:B" & UBound(myArr)) = myArr
Range("A2:A" & LRow).SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete


Howard
 
Hi Howard,

Am Fri, 21 Feb 2014 02:04:50 -0800 (PST) schrieb L. Howard:
This clears the A column cell, where I presume there is no 'Cut' available in an array, so that cell is still occupied until cleared.
Click to expand...

no, myArr(i,1) is not cleared. It is a empty string. You can't delete an
element of the array this way
This puts all the new data back into columns A and B. So if the columns were cleared one step ago why would you run another Entire.Delete Row?
Click to expand...

yes, but also the empty strings will be inserted. Therefore it is
necessary to delete empty rows.


Regards
Claus B.
 
Hi Howard,



Am Fri, 21 Feb 2014 02:04:50 -0800 (PST) schrieb L. Howard:






no, myArr(i,1) is not cleared. It is a empty string. You can't delete an

element of the array this way




yes, but also the empty strings will be inserted. Therefore it is

necessary to delete empty rows.





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

Okay, makes sense now.

Still trying to figure the second 1 in the left portion.

Howard
 
Hi Howard,

Am Fri, 21 Feb 2014 02:27:54 -0800 (PST) schrieb L. Howard:
Still trying to figure the second 1 in the left portion.
Click to expand...

it is an element of an array.
The element is myArr(i,1) because it is from the most left column.
And for Left(myArr(i,1),1) the first 1 is the column from the array,
the second one the counter of left.

But better try Sub MyScan3. It is faster.


Regards
Claus B.
 
Hi Howard,

Am Fri, 21 Feb 2014 02:27:54 -0800 (PST) schrieb L. Howard:
Still trying to figure the second 1 in the left portion.
Click to expand...

if you loop through a range and put the values in an array like
for each rngC in myRng
myarr(i)=rngC.Value
i=i+1)
next
you get a 1D-Array. That array has 1 row and n columns

But if you read a range in an array you get a 2D-Array.
That array is build just like a table. If you read A2:B3 into an array
A2 is myArr(1, 1), B2 is myArr(1, 2), A3 is myArr(2, 1) and B3 is
myArr(2, 2)
The first number is row index, the second one the column index


Regards
Claus B.
 
Hi Howard,

still a little bit faster. Write the array without the empty elements
into another array and dump it back into the sheet:

Option Explicit
Option Base 1

Sub MyScan4()
Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row

myArr = Range("A2:B" & LRow)
For i = LBound(myArr) To UBound(myArr)
If Left(myArr(i, 1), 1) <> "P" Then
myArr(i - 1, 2) = myArr(i, 1)
myArr(i, 1) = ""
End If
Next

Range("A2:B" & LRow).ClearContents
j = 1
For i = LBound(myArr) To UBound(myArr)
ReDim Preserve arrOut(1 To UBound(myArr), 1 To 2)
If myArr(i, 1) <> "" Then
arrOut(j, 1) = myArr(i, 1)
arrOut(j, 2) = myArr(i, 2)
j = j + 1
End If
Next

Range("A2").Resize(UBound(arrOut), 2) = arrOut
End Sub


Regards
Claus B.
 
Hi Howard,

Am Fri, 21 Feb 2014 14:38:10 +0100 schrieb Claus Busch:
still a little bit faster. Write the array without the empty elements
into another array and dump it back into the sheet:
Click to expand...

and once again a bit faster:

Option Explicit
Option Base 1

Sub MyScan5()
Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long
Dim myCt As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row

myArr = Range("A2:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")
j = 1
For i = LBound(myArr) To UBound(myArr)
ReDim Preserve arrOut(myCt, 2)
If Left(myArr(i, 1), 1) = "P" Then
arrOut(j, 1) = myArr(i, 1)
j = j + 1
Else
arrOut(j - 1, 2) = myArr(i, 1)
End If
Next

Range("A2:B" & LRow).ClearContents
Range("A2").Resize(UBound(arrOut), 2) = arrOut

End Sub


Regards
Claus B.
 
Hi Howard,



Am Fri, 21 Feb 2014 14:38:10 +0100 schrieb Claus Busch:







and once again a bit faster:



Option Explicit

Option Base 1



Sub MyScan5()

Dim LRow As Long

Dim myArr As Variant

Dim arrOut() As Variant

Dim i As Long, j As Long

Dim myCt As Long



LRow = Cells(Rows.Count, 1).End(xlUp).Row



myArr = Range("A2:A" & LRow)

myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")

j = 1

For i = LBound(myArr) To UBound(myArr)

ReDim Preserve arrOut(myCt, 2)

If Left(myArr(i, 1), 1) = "P" Then

arrOut(j, 1) = myArr(i, 1)

j = j + 1

Else

arrOut(j - 1, 2) = myArr(i, 1)

End If

Next



Range("A2:B" & LRow).ClearContents

Range("A2").Resize(UBound(arrOut), 2) = arrOut



End Sub





Regards

Claus B.

--
Click to expand...

Just got back to my computer.

Thanks for all the schooling, appreciate it.

I'll give the faster fastest code a try.

Thanks.

Howard
 
Wow, both Scan4 and Scan5 are lightning fast.

I am using 10,000 rows and its done in a blink for both codes.

Into my cheat sheet for these, and hope I can use for examples to modify and do other similar stuff.

Thanks, Claus.
 
Wrong scenario to impliment the concept exampled in Sub GarryScan()!

Claus' approach is a much more efficient way to go since it loads the
array in one shot and works directly on the elements in memory. Also,
there's no transfer functions required to 'dump' the array back into a
worksheet.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Wrong scenario to impliment the concept exampled in Sub GarryScan()!



Claus' approach is a much more efficient way to go since it loads the

array in one shot and works directly on the elements in memory. Also,

there's no transfer functions required to 'dump' the array back into a

worksheet.
Click to expand...

Oh Boy, I have a lot to learn using arrays, that I can see.

Thanks for the note.

Howard
 
Back
Top