从Excel范围有效地将单元格属性分配给VBA / VB.NET中的数组 [英] Efficiently assign cell properties from an Excel Range to an array in VBA / VB.NET

问题描述

在VBA / VB.NET中，可以将Excel范围值分配给数组，以实现更快的访问/操作。有没有办法有效地将其他单元格属性（例如顶，左，宽，高）分配给数组？也就是说，我想做一些例子：

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

代码是以编程方式检查图像是否与工作簿中使用的单元格重叠的例程的一部分。我现在在UsedRange中迭代单元格的方法很慢，因为它需要重复轮询单元格的顶/左/宽/高。

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）通过查看每行中第一个单元格的顶部和高度来查找使用范围中有趣的一组行（我的理解是行中的所有单元格必须具有相同的顶部和高度，但不能保留和宽度）

(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）迭代有趣行中的单元格并执行重叠检测仅使用单元格的左右位置。

(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

推荐答案

Todd，

我可以想到的最好的解决方案是将顶部转储到一个范围内，然后将这些范围值转储成一个变量阵列。如你所说，For Next（在我的测试中为10,000个单元格）花费了几秒钟。所以我创建了一个返回其输入的单元格顶部的函数。
下面的代码主要是一个函数，用于复制传递给它的工作表的使用范围，然后将上述功能输入到已复制工作表的使用范围的每个单元格中。然后将该范围转置并转储到变量数组中。

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.

10,000个单元格只需要一秒钟左右。不知道是否有用，但这是一个有趣的问题。如果它是有用的，你可以为每个属性创建一个单独的函数或传递你正在寻找的属性，或返回四个数组（？）...

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，

在回答您的要求时对于非定制的UDF，我只能提供一个接近您开始的解决方案。 10,000个细胞需要约10倍的时间。不同之处在于你回到循环细胞。

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.

我把我的个人信封放在这里，所以也许有人会有一种方法去没有自定义的UDF。

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

这篇关于从Excel范围有效地将单元格属性分配给VBA / VB.NET中的数组的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！