excel - Excel VBA - 检查特定工作表和命名单元格的功能是否存在于工作簿中

Question

我有一个 sub 打开我创建的清单的旧版本，然后导入数据。用户选择文件后，我想检查该工作表上的特定工作表和命名单元格是否存在（为了验证，他们选择了正确的文件 - 工作表将始终为“主页”，单元格为“版本”）。如果其中任何一个都不存在，那么我想要一个消息框并退出 sub。如果它们都存在，则继续进行其余的导入。

大部分都有效，这只是对命名工作表/单元格的第一次检查。主要问题是这部分子：

If Not WorksheetExists("Main Page") Then
    MsgBox "The selected file does not appear to be an older version of the checklist." & vbNewLine & vbNewLine & "Please check that you have selected the correct file."
    wbCopyFrom.Close SaveChanges:=False
    Exit Sub
End If

和被调用的函数：

Function WorksheetExists(sName As String) As Boolean

WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")

End Function

目前，此功能可以很好地检查工作表名称。但是我对如何检查单元格名称有点困惑——我需要另一个函数还是我可以编辑上面的函数来同时检查两者？IE。我想我可以换行：

WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")

包括单元名称而不是 A1 位。

如果有帮助的话，整个子函数和其他函数都在下面。

Sub ImportLists()

If MsgBox("The import process will take some time (approximately 10 minutes); please be patient while it is running. It is recommended you close any other memory-intensive programs before continuing. Click 'Cancel' to run at another time.", vbOKCancel) = vbCancel Then Exit Sub

Application.ScreenUpdating = False

Dim OldFile As Variant, wbCopyFrom As Workbook, wsCopyFrom As Worksheet, wbCopyTo As Workbook, wsCopyTo As Worksheet, OutRng As Range, c As Range, RangeName As Range

Set wbCopyTo = ActiveWorkbook
ChDir ThisWorkbook.Path
OldFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & "*.xls*", 1, "Select a previous version of the checklist", "Import", False)

If TypeName(OldFile) = "Boolean" Then
    MsgBox "An error occured while importing the old version." & vbNewLine & vbNewLine & "Please check you have selected the correct checklist file and filetype (.xlsm)."
Exit Sub
End If

Set wbCopyFrom = Workbooks.Open(OldFile)

If Not WorksheetExists("Main Page") Then
    MsgBox "The selected file does not appear to be an older version of the checklist." & vbNewLine & vbNewLine & "Please check that you have selected the correct file."
    wbCopyFrom.Close SaveChanges:=False
    Exit Sub
End If

OldVersion = Right(wbCopyFrom.Sheets("Main Page").Range("Version").Value, Len(wbCopyFrom.Sheets("Main Page").Range("Version").Value) - 1)
NewVersion = Right(wbCopyTo.Sheets("Main Page").Range("Version").Value, Len(wbCopyTo.Sheets("Main Page").Range("Version").Value) - 1)

If NewVersion < OldVersion Then
    MsgBox "The selected older version of the checklist (v" & OldVersion & ") appears to be newer than the current version (v" & NewVersion & ")." & vbNewLine & vbNewLine & "Please check that you have selected the correct older version of the checklist or that the current checklist is not an older version."
    wbCopyFrom.Close SaveChanges:=False
    Exit Sub
End If

For Each wsCopyFrom In wbCopyFrom.Worksheets
    If wsCopyFrom.Name <> "Set List" And wsCopyFrom.Name <> "Rarity Type Species List" And wsCopyFrom.Name <> "Need List" And wsCopyFrom.Name <> "Swap List" And wsCopyFrom.Name <> "Reference List" Then
        Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
        Set OutRng = UsedRangeUnlocked(wsCopyFrom)
        If Not OutRng Is Nothing Then
            For Each c In OutRng
                If wsCopyTo.Range(c.Address).Locked = False Then
                    c.Copy wsCopyTo.Range(c.Address)
                End If
            Next c
        End If
    End If
Next wsCopyFrom

wbCopyFrom.Close SaveChanges:=False
Call CalcRefilter

Application.ScreenUpdating = True

MsgBox "The checklist was successfully imported from version " & OldVersion & " and updated to version " & NewVersion & "." & vbNewLine & vbNewLine & "Don't forget to save the new version."

End Sub

Function WorksheetExists(sName As String) As Boolean

WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")

End Function

Function UsedRangeUnlocked(ws As Worksheet) As Range

Dim RngUL As Range, c As Range

For Each c In ws.UsedRange.Cells
    If Not c.Locked Then
        If RngUL Is Nothing Then
            Set RngUL = c
        Else
            Set RngUL = Application.Union(RngUL, c)
        End If
    End If
Next c
Set UsedRangeUnlocked = RngUL

End Function

标签： excelvbanamed-ranges

Answer 1

您可以尝试访问该范围。如果它抛出一个错误它不存在：

Function RangeExists(RangeName As String) As Boolean
    Dim rng As Range
    On Error Resume Next
    Set rng = Range(RangeName)
    On Error GoTo 0 'needed to clear the error. Alternative Err.Clear
    RangeExists = Not rng Is Nothing
End Function

或者立即检查两者是否存在（工作表和范围）：

Function SheetAndRangeExists(WorksheetName As String, RangeName As String) As Boolean
    Dim rng As Range
    On Error Resume Next
    Set rng = Worksheets(WorksheetName).Range(RangeName)
    On Error GoTo 0
    SheetAndRangeExists = Not rng Is Nothing
End Function

如果要在特定工作簿中对其进行测试：

Function SheetAndRangeExists(InWorkbook As Workbook, WorksheetName As String, RangeName As String) As Boolean
    Dim rng As Range
    On Error Resume Next
    Set rng = InWorkbook.Worksheets(WorksheetName).Range(RangeName)
    On Error GoTo 0
    SheetAndRangeExists = Not rng Is Nothing
End Function

并打电话给SheetAndRangeExists(ThisWorkbook, "Main Page", "Version")