Таблицы 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.ApplicationFilename = "БазаДанных.mdb" If Dir(ThisWorkbook.Path & "\" & Filename) <> "" Then Set Database = DAO.OpenDatabase(ThisWorkbook.Path & "\" & Filename, True, True) End Ifxl.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 = NothingEnd SubПодскажите пожалуйста, как добавить в данный код проверку совпадения имен существующих в книге Листов с именами выгружаемых таблиц Access, т.е. если в активной книге Excel существует Лист и он совпадает по своему имени с именем любой таблицы Access, то новый лист (с именем таблицы Access) не создавать. Заранее спасибо.
6 ответов

Этот кусок
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
Прошу прощения. При данном изменении макрос работает как надо! Я попробовала на другом компьютере - все работает. Пока не знаю почему не работает на моем компьютере. Спасибо!