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

2023年8月26日 250次阅读

在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

最佳答案 托德,

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

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
点赞