Таблицы Access в Листы Excel дописать код

[ольгаг]

Здравствуйте Уважаемые программисты!
Есть файл-база с таблицами в Access (например, Таблица1, Таблица2 и т.д.).
Код приведенный ниже (находится в активной книге Excel) позволяет из файла Access в активную книгу Excel импортировать данные этих таблиц
предварительно создав Листы Excel с именами равными именам таблиц Access.

Private Sub Workbook_Open()

Dim Database As DAO.Database
Dim rs As DAO.Recordset
Dim Filename As String
Dim tb As DAO.TableDef
Dim Sheet As Worksheet
Dim wkbk As Excel.Workbook
Dim wksht As String
Dim i As Integer
Dim xl As New Excel.Application

Filename = "БазаДанных.mdb"
If Dir(ThisWorkbook.Path & "\" & Filename) <> "" Then
Set Database = DAO.OpenDatabase(ThisWorkbook.Path & "\" & Filename, True, True)
End If

xl.DisplayAlerts = False
With wkbk
For Each tb In Database.TableDefs
If Left(tb.Name, 4) <> "MSys" Then
Set rs = Database.OpenRecordset(tb.Name, dbOpenDynaset)
wksht = tb.Name
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = wksht
Sheets(wksht).Range("A1").CopyFromR ecordset rs
End If
Next tb
End With
xl.DisplayAlerts = True
rs.Close
xl.Quit
Set wkbk = Nothing
Set xl = Nothing
Set rs = Nothing
Set Database = Nothing

End Sub

Подскажите пожалуйста, как добавить в данный код проверку совпадения имен существующих в книге Листов с именами выгружаемых таблиц Access, т.е. если в активной книге Excel существует Лист и он совпадает по своему имени с именем любой таблицы Access, то новый лист (с именем таблицы Access) не создавать.
Заранее спасибо.

[Казанский]

Этот кусок

wksht = tb.Name
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = wksht
Sheets(wksht).Range("A1").CopyFromRecordset rs

надо изменить так:

wksht = tb.Name
On Error Resume Next
Set Sheet = Sheets(wksht)
If Err Then 'лист не существует
    Err.Clear
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = wksht
    Sheets(wksht).Range("A1").CopyFromRecordset rs
Else        'лист существует
    'какие-то действия с Sheet
End If

[ольгаг]

Сообщение от Казанский

Этот кусок

wksht = tb.Name
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = wksht
Sheets(wksht).Range("A1").CopyFromRecordset rs

надо изменить так:

wksht = tb.Name
On Error Resume Next
Set Sheet = Sheets(wksht)
If Err Then 'лист не существует
    Err.Clear
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = wksht
    Sheets(wksht).Range("A1").CopyFromRecordset rs
Else        'лист существует
    'какие-то действия с Sheet
End If

Спасибо за код, я попробую.
Подскажите пожалуйста, как исправить появление ошибки "Error in loading dll" в строке:
For Each tb In Database.TableDefs?

[ольгаг]

Сообщение от Казанский

Этот кусок

wksht = tb.Name
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = wksht
Sheets(wksht).Range("A1").CopyFromRecordset rs

надо изменить так:

wksht = tb.Name
On Error Resume Next
Set Sheet = Sheets(wksht)
If Err Then 'лист не существует
    Err.Clear
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = wksht
    Sheets(wksht).Range("A1").CopyFromRecordset rs
Else        'лист существует
    'какие-то действия с Sheet
End If

Я попробовала изменить код как Вы сказали (только изменила If Err на If Not Err - иначе листы не создавались, даже если их не было в книге). В итоге вылетает сообщение что лист с таким именем существует и создается новый пустой лист.

[Казанский]

> Я попробовала изменить код как Вы сказали (только изменила If Err на If Not Err ...

Супер! Теперь условие выполняется ВСЕГДА (долго объяснять, почему).
Может, есть СКРЫТЫЕ листы с такими именами?

[ольгаг]

Сообщение от Казанский

> Я попробовала изменить код как Вы сказали (только изменила If Err на If Not Err ...

Супер! Теперь условие выполняется ВСЕГДА (долго объяснять, почему).
Может, есть СКРЫТЫЕ листы с такими именами?

Скрытых листов нет.
Код работает и добавляет Листы с именами таблиц Access, но если такие Листы уже есть в книге Excel, то повторно они не должны добавляться - это
пока у меня не получается сделать.

[ольгаг]

Сообщение от Казанский

Этот кусок

wksht = tb.Name
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = wksht
Sheets(wksht).Range("A1").CopyFromRecordset rs

надо изменить так:

wksht = tb.Name
On Error Resume Next
Set Sheet = Sheets(wksht)
If Err Then 'лист не существует
    Err.Clear
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = wksht
    Sheets(wksht).Range("A1").CopyFromRecordset rs
Else        'лист существует
    'какие-то действия с Sheet
End If

Прошу прощения. При данном изменении макрос работает как надо!
Я попробовала на другом компьютере - все работает.
Пока не знаю почему не работает на моем компьютере.
Спасибо!