有效地将 Excel 范围中的单元格属性分配给 VBA / VB.NET 中的数组

Question

在 VBA / VB.NET 中，您可以将 Excel 范围值分配给数组，以便更快地访问/操作。有没有办法有效地将其他单元格属性（例如，顶部、左侧、宽度、高度）分配给数组？即，我想做类似的事情：

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

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

更新：我将继续接受 Doug 的回答，因为它确实比简单迭代更快。最后，我发现非天真的迭代工作得更快为了检测与内容填充单元格重叠的控件。步骤基本上是：

(1) 通过查看每行中第一个单元格的顶部和高度，在使用范围内找到有趣的行集（我的理解是该行中的所有单元格必须具有相同的顶部和高度，但是不是左和宽度）

(2) 遍历感兴趣行中的单元格，只使用单元格的左右位置进行重叠检测。

查找感兴趣的行集的代码如下所示：

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

Answer 1

托德，

我能想到的最佳解决方案是将顶部转储到一个范围中，然后将这些范围值转储到一个变体数组中。正如您所说，For Next（在我的测试中针对 10,000 个细胞）需要几秒钟。所以我创建了一个函数，它返回它输入的单元格的顶部。 下面的代码主要是一个函数，它复制你传递给它的工作表的 usedrange，然后将上述函数输入到复制工作表的 usedrange 的每个单元格中。然后，它将该范围转置并转储到一个变体数组中。

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

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

托德，

为了回答您对非自定义 UDF 的要求，我只能提供与您开始时接近的解决方案。 10,000 个细胞需要大约 10 倍的时间。不同之处在于您要循环遍历单元格。

我在这里推我的个人信封，所以也许有人可以在没有自定义 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

Answer 2

我会在@Doug 中添加以下内容

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

它显示了将范围放入数组并再次返回的基本过程。