Hi Tushar

Very interesting! and thanks. (Earlier today we posted
exactly same time.)

I've adapted my array method to tie in with your code
(In "TestIt", change "MimicARange2" to "ArrayToRng2").

With 500 areas both methods take virtually the same time.
But with 1000 areas in your "CreateTestRng", the array
method apears a bit more than twice as fast.


Function ArrayToRng2(Rng1 As Range, NewSheet As Worksheet)
As Range
Dim aRng() As Range
Dim nAreas As Long
Dim i As Long, j As Long, k As Long, div As Byte
Dim a As Range
Dim t As Single

' t = myTimerFunction
div = 94

If Rng1 Is Nothing Then Exit Function
nAreas = Rng1.Areas.Count

On Error Resume Next
Set ArrayToRng2 = NewSheet.Range(Rng1.Address)
On Error GoTo 0
If ArrayToRng2.Areas.Count = nAreas Then Exit Function

j = CLng(nAreas / div)
If nAreas / div j Then j = j + 1

ReDim aRng(1 To j)
On Error GoTo skip 'done remainder
With NewSheet
For k = 1 To j
Set aRng(k) = .Range(Rng1.Areas(1 + (k - 1) _
* div).Address)
For i = 2 To div
Set aRng(k) = Union(aRng(k), _
.Range(Rng1.Areas(i + (k - 1) _
* div).Address))
Next
Next
End With
skip:
Set ArrayToRng2 = aRng(1)
For k = 2 To j
Set ArrayToRng2 = Union(ArrayToRng2, aRng(k))
Next
Erase aRng
't = myTimerFunction - t: 'Debug.Print t

End Function

Regards,
Sandy
savituk yahoo co uk


-----Original Message-----
Why pre-determine anything? Since we know the limit is
the length of
the address string, just use that as the limiting factor.

Option Explicit

Function createTestRng(aWKS As Worksheet) As Range
Dim i As Integer
With aWKS
Set createTestRng = .Range("aa1:ab3")
For i = 2 To 500
Set createTestRng = Union(createTestRng, _
.Range("aa" & (i - 1) * 5).Resize(2, 2))
Next i
End With
End Function
Function MimicARange2(Rng1 As Range, newSheet As
Worksheet) As Range
Dim i As Integer, sAddr As String, CharsRemaining As
Integer, _
OneRngAddr As String
If Rng1 Is Nothing Then Exit Function
On Error Resume Next
Set MimicARange2 = newSheet.Range(Rng1.Address)
On Error GoTo 0
If MimicARange2.Areas.Count = Rng1.Areas.Count Then
Exit Function
With newSheet
If MimicARange2 Is Nothing Then
Set MimicARange2 = .Range(Rng1.Areas(1).Address)
End If
CharsRemaining = 256: sAddr = ""
For i = MimicARange2.Areas.Count + 1 To
Rng1.Areas.Count
OneRngAddr = Rng1.Areas(i).Address
If CharsRemaining <= Len(OneRngAddr) Then
Set MimicARange2 = Union(MimicARange2, _
.Range(Mid(sAddr, 2)))
CharsRemaining = 256: sAddr = ""
End If
sAddr = sAddr & "," & OneRngAddr
CharsRemaining = CharsRemaining - 1 - Len
(OneRngAddr)
Next i
If sAddr < "" Then
Set MimicARange2 = Union(MimicARange2, _
.Range(Mid(sAddr, 2)))
End If
End With
End Function
Sub testIt()
Dim i As Integer, Rng1 As Range, Rng2 As Range
Set Rng1 = createTestRng(ActiveWorkbook.Worksheets(1))
MsgBox Rng1.Parent.Name & ", " & Rng1.Areas.Count
& ", " _
& Len(Rng1.Address) & ", " & Rng1.Address
Set Rng2 = MimicARange2(Rng1,
ActiveWorkbook.Worksheets(2))
MsgBox Rng2.Parent.Name & ", " & Rng2.Areas.Count
& ", " _
& Len(Rng2.Address) & ", " & Rng2.Address
End Sub




--
Regards,

Tushar Mehta, MS MVP -- Excel
www.tushar-mehta.com
Excel, PowerPoint, and VBA add-ins, tutorials
Custom MS Office productivity solutions

In article ,
says...
Thanks Harlan, that's great

Actually I was thinking along similar lines, but with a
different method.

I had noticed that Union of up to about 100 areas is
pretty quick, thereafter time increases exponentially.
What I am doing now is to Union 94* areas at a time
into a
range array, then Union each of the array elements into
a
single range.
(*94 seems about optimum)

In my ageing system I get these times with a sample of
1100 areas:

Simple Loop & Union per my original post: 19.7 sec
Chunks of 12 area strings: 2.04 sec
94 areas to array elements, then union all: 0.71 sec

Different samples might give different relative results.

If interested in the code drop me a line (I'll little
tidy
it up a little).

Thanks again,
Sandy
savituk yahoo co uk

to top post seems to conform to the convention of this
NG <g

-----Original Message-----
"Tom Ogilvy" wrote...
A faster way doesn't come to mind. (given the
limitations you cite)
...

Accumulate multiple area ranges in 12-area chunks.
Faster
than one area at a
time, but only a constant factor speed-up.


Sub foo()
Dim i As Long, k As Long, n As Long, a As String
Dim r As Range

n = Selection.Areas.Count

For k = 1 To n Step 12
a = ""

For i = 0 To IIf(k + 12 n, n - k, 11)
a = a & "," & Selection.Areas(k + i).Address
Next i

a = Mid(a, 2)

If r Is Nothing Then
Set r = Range(a)

Else
Set r = Union(r, Range(a))

End If

Next k

MsgBox r.Areas.Count & Chr(13) & r.Cells.Count

End Sub

--
To top-post is human, to bottom-post and snip is
sublime.
.


.