Excel VBA - функция для проверки определенного листа и именованной ячейки существует в книге - PullRequest
Новая
       47

Excel VBA - функция для проверки определенного листа и именованной ячейки существует в книге

0 голосов
/ 20 ноября 2018

У меня есть подпрограмма, которая открывает старую версию созданного мной контрольного списка, а затем импортирует данные.После того, как пользователь выберет файл, я хочу проверить, существует ли конкретный лист и именованная ячейка на этом листе (для проверки они выбрали правильный файл - лист всегда будет «Главная страница» и ячейка «Версия»).Если ни один из них не существует, то я хочу окно сообщения и выйти из подпрограммы.Если они оба существуют, продолжите импорт.

Большинство из них работает, это просто первая проверка для указанного листа / ячейки.Основной проблемой является этот бит подпрограммы: 

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

Эта функция в данный момент проверяет точное имя листа.Но я немного запутался в том, как проверить имя ячейки - нужна ли мне другая функция или я могу просто отредактировать вышеуказанную функцию, чтобы проверить обе функции одновременно?то есть.Я думаю, что я могу изменить строку: 

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

1 Ответ

0 голосов
/ 20 ноября 2018

Вы можете попытаться получить доступ к диапазону.Если выдается ошибка, ее не существует: 

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

...