Excel VBA - 检查工作簿中是否存在特定工作表和命名单元格的函数

Question

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

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

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

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")