Set Range Var with address length over 256

  • Thread starter Thread starter Sandy V
  • Start date Start date
S

Sandy V

I want to set a range variable with the address of
variable already set in another workbook. The problem is
if the address length is more than 256 (approx 17 to 25
areas).

The following seems to work, but the Loop & Union method
is slow with a very large number of areas.

Sub CopyRngVar()
Dim Rng1 As Range 'in active WB
Dim Rng2 As Range 'destined another WB
Dim a As Range

Set Rng1 = Range("A1:B3,A5:B6")

With Workbooks("Book2").Worksheets("Sheet1")

'this works if address length < 256
'Set Rng2 = .Range(Rng1.Address)

For Each a In Rng1.Areas
If Rng2 Is Nothing Then
Set Rng2 = .Range(a.Address)
Else
Set Rng2 = Union(Rng2, .Range(a.Address))
End If
Next

End With
Rng2.Interior.ColorIndex = 5

End Sub

Any ideas for a something more efficient much appreciated,
TIA,
Sandy

Savituk yahoo co uk
 
Seems like looping through the areas and setting the colors should be
relatively fast. (unless you need the rng2 reference set).


set sh = Workbooks("Book2.xls").Worksheest("Sheet1")
for each ar in rng1.Areas
sh.Range(ar.Address).Interior.ColorIndex = 5
Next
 
Thanks Tom for replying.

Unfortunately I do need to set Rng2 with the address of
Rng1 for further manipulation in the second wb. The
colorindex bit in my example was purely to verify in the
test sub that Rng2 was correctly set (I should have
clarified that).

Ideally what I'd like to do is change the parent(s) of the
original variable (or a direct copy of it), which
obviously I can't. If the range contains say 500 areas,
my loop & union method is slow, especially when repeated a
few times.

Regards,
Sandy
savituk yahoo co uk
 
Tom,

Although hopeful I wasn't very optimistic there would be,
but thanks for looking at it. Even a "no can do", or in
this case "nothing better" type response is appreciated -
stops me pursuing a lost cause!

Regards,
Sandy
 
A faster way doesn't come to mind. (given the limitations you cite)
Click to expand...
...

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
 
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
 
Wow! This is scary. I don't get an error when setting a range to the
address of another that has a lot of areas, but the result is
incorrect. XL simply uses just enough areas to provide a address
string that is under 256 characters -- unf**king believable!

For example, in the code below, the statement
Set MimicARange = newSheet.Range(Rng1.Address)
simply sets MimicARange to mimic the first 21 areas of Rng1!

Any way, the workaround is to use the MimicARange function to do what
you want as shown in the testIt sub below.

Option Explicit

Function createTestRng(aWKS As Worksheet) As Range
Dim i As Integer
With aWKS
Set createTestRng = .Range("a1:b3")
For i = 2 To 50
Set createTestRng = Union(createTestRng, _
.Range("a" & (i - 1) * 5).Resize(2, 2))
Next i
End With
End Function
Function MimicARange(Rng1 As Range, newSheet As Worksheet) As Range
Dim i As Integer
If Rng1 Is Nothing Then Exit Function
On Error Resume Next
Set MimicARange = newSheet.Range(Rng1.Address)
On Error GoTo 0
If MimicARange.Areas.Count = Rng1.Areas.Count Then Exit Function
With newSheet
If MimicARange Is Nothing Then
Set MimicARange = .Range(Rng1.Areas(1).Address)
End If
For i = MimicARange.Areas.Count + 1 To Rng1.Areas.Count
Set MimicARange = Union(MimicARange, _
.Range(Rng1.Areas(i).Address))
Next i
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 = MimicARange(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
 
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
Click to expand...
 
Back
Top