简体   繁体   中英

Excel VBA - Function to check a specific sheet and named cell exists in workbook

I have a sub which opens an older version of a checklist I've created, and then imports the data. After the user selects the file, I want to check if a specific sheet and named cell on that sheet exists (for validation they have picked the correct file - the sheet will always be "Main Page" and the cell "Version"). If either doesn't exist, then I want a message box and to exit sub. If they both exist, then continue with the rest of the import.

Most of it works, it's just the first check for the named sheet/cell. The main problem is this bit of the 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

And the called function:

Function WorksheetExists(sName As String) As Boolean

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

End Function

This function at the moment checks the sheet name fine. But I'm getting a little confused on how to check the cell name - do I need another function or can I just edit the above function to check for both at the same time? ie. I think I can change the line:

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

to include the cell name instead of the A1 bit.

The whole sub and other functions are below for context if that helps.

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

You can try to access the range. If it throws an error it does not exist:

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

Or to check at once if both exists (worksheet and range):

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

If you want to test it in a specific workbook:

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

and call like SheetAndRangeExists(ThisWorkbook, "Main Page", "Version")

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM