Question

我在MS Access中运行一个例程来操作MS Excel。我正在从工作簿中的所有工作表中创建一个合并报表工作表。只有部分工作表具有命名范围“dockName”。我的例程是使用停靠栏名称和相关的工作表名称创建一个数组。在合并工作表上，我包括一个停靠名称列表和指向相关工作表的超链接。

下面的代码可以工作，但它会横截工作表两次，我相信有更好的方法可以获得具有命名范围“dockName”的工作表总数

   ' cycle through each worksheet to find out if
   ' the worksheet has a named range of "dockName"
   ' if the named range is found increment irow

   For Each ws In wbWorking.Worksheets
        On Error Resume Next
            Set rngDock = ws.Range("dockName")
        On Error GoTo err_trap
        If Not rngDock Is Nothing Then
            irow = irow + 1
        End If
    Next ws

    If Not ws Is Nothing Then Set ws = Nothing

    ' redim an array with the appropriate number of rows
    icol = 1
    ReDim vDockSheetNames(irow, icol)
    irow = 0

    ' cycle through the worksheets and gather the 
    ' dockName and worksheet Name into vDockSheetNames array

    For Each ws In wbWorking.Worksheets
        On Error Resume Next
            Set rngDock = ws.Range("dockName")
        On Error GoTo err_trap
        If Not rngDock Is Nothing Then
            vDockSheetNames(irow, 0) = rngDock.Value2
            vDockSheetNames(irow, 1) = ws.name
            irow = irow + 1
        End If
    Next ws

Answer 1

ReDim很多次都没问题。

Sub TestRedim()

    Dim myAr() As String
    Dim i As Long
    Dim TimeStart As Single

    TimeStart = Timer()
    For i = 1 To 1000000
        ReDim Preserve myAr(1 To i)
        myAr(i) = "Sheet " & i
    Next i

    MsgBox "That took " & Format(Timer - TimeStart, "0.000") & " seconds.", vbInformation

End Sub

我不得不将循环次数增加到1百万，以获得超过1秒的时间。

这需要我的电脑1.1秒。与

    Dim myAr(1 To 1000000) As String

并且没有ReDim行，它是0.4秒。不值得任何进一步的想法。

正如SJR在你的第一个循环中写道ReDim。循环Worksheets集合并检查命名范围的大小更为昂贵。

Answer 2

基于@SJR的建议和@Andre的支持建议，我生成了以下函数，该函数返回给定工作簿中给定命名范围的计数。返回值可用于重新生成数组。它的功能明显快于横向工作表收集和测试命名范围。

Function getCountOfNamedRanges(ByRef wb As Excel.Workbook, ByVal rngName As String) As Integer
    ' return the number of times a given rngName appears in the given workbook
    Dim nm As Variant
    Dim nms As Names
    Dim i As Integer
    Dim iReturn As Integer

    Set nms = wb.Names
    For i = 1 To nms.Count
        If InStr(1, nms(i).Name, rngName) Then iReturn = iReturn + 1
    Next i
    countNameRanges = iReturn
End Function

查找具有特定命名范围的所有工作表

2 个答案: