CODEWITHSUNDEEP
vb.netvbaexcel
Todd Schiller
Todd Schiller

Reputation: 486

Efficiently assign cell properties from an Excel Range to an array in VBA / VB.NET

In VBA / VB.NET you can assign Excel range values to an array for faster access / manipulation. Is there a way to efficiently assign other cell properties (e.g., top, left, width, height) to an array? I.e., I'd like to do something like:

 Dim cellTops As Variant : cellTops = Application.ActiveSheet.UsedRange.Top

The code is part of a routine to programmatically check whether an image overlaps cells that are used in a workbook. My current method of iterating over the cells in the UsedRange is slow since it requires repeatedly polling for the top / left / width / height of the cells.

Update: I'm going to go ahead an accept Doug's answer as it does indeed work faster than naive iteration. In the end, I found that a non-naive iteration works faster for my purposes of detecting controls that overlap content-filled cells. The steps are basically:

(1) Find the interesting set of rows in the used range by looking at the tops and heights of the first cell in each row (my understanding is that all the cells in the row must have the same top and height, but not left and width)

(2) Iterate over the cells in the interesting rows and perform overlap detection using only the left and right positions of the cells.

The code for finding the interesting set of rows looks something like:

Dim feasible As Range = Nothing

For r% = 1 To used.Rows.Count
    Dim rowTop% = used.Rows(r).Top
    Dim rowBottom% = rowTop + used.Rows(r).Height

    If rowTop <= objBottom AndAlso rowBottom >= objTop Then
        If feasible Is Nothing Then
            feasible = used.Rows(r)
        Else
            feasible = Application.Union(used.Rows(r), feasible)
        End If
    ElseIf rowTop > objBottom Then
        Exit For
    End If
Next r

Upvotes: 4

Views: 4471

Answers (2)

John Alexiou
John Alexiou

Reputation: 29244

I would add to @Doug the following 

Dim r as Range
Dim data() as Variant, i as Integer

Set r = Sheet1.Range("A2").Resize(100,1)
data = r.Value
' Alternatively initialize an empty array with
' ReDim data(1 to 100, 1 to 1)

For i=1 to 100
    data(i,1) = ...
Next i

r.Value = data

which shows the basic process of getting a range into an array and back again.

Upvotes: -1

Doug Glancy
Doug Glancy

Reputation: 27478

Todd,

The best solution I could think of was to dump the tops into a range and then dump those range values into a variant array. As you said, the For Next (for 10,000 cells in my test) took a few seconds. So I created a function that returns the top of the cell that it's entered into. The code below, is mainly a function that copies the usedrange of a sheet you pass to it and then enters the function described above into each cell of the usedrange of the copied sheet. It then transposes and dumps that range into a variant array.

It only takes a second or so for 10,000 cells. Don't know if it's useful, but it was an interesting question. If it is useful you could create a separate function for each property or pass the property you're looking for, or return four arrays(?)...

Option Explicit
Option Private Module

Sub test()
Dim tester As Variant

tester = GetCellProperties(ThisWorkbook.Worksheets(1))
MsgBox tester(LBound(tester), LBound(tester, 2))
MsgBox tester(UBound(tester), UBound(tester, 2))

End Sub

Function GetCellProperties(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
rngCopyOfUsedRange.Formula = "=CellTop()"
wsTemp.Calculate
GetCellProperties = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Function

Function CellTop()
CellTop = Application.Caller.Top
End Function

Todd,

In answer to your request for a non-custom-UDF I can only offer a solution close to what you started with. It takes about 10 times as long for 10,000 cells. The difference is that your back to looping through cells.

I'm pushing my personal envelope here, so maybe somebody will have a way to to it without a custom UDF.

Function GetCellProperties2(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
With rngCopyOfUsedRange
For i = 1 To .Cells.Count
.Cells(i).Value = wsSourceWorksheet.UsedRange.Cells(i).Top
Next i
End With
GetCellProperties2 = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Function

Upvotes: 3

Related Questions