MyTetra Share
Делитесь знаниями!
Excel->Access(ado)
16.03.2019
23:43
Текстовые метки: ado,
Раздел: !Закладки - VBA - Access - Excel->Access

Я бы сделал, например, так - на DAO (исполняется в Excel):

Sub fromExcelToAccess()
    Dim dbe As Object 'DAO.DBEngine
    Dim db  As Object 'DAO.Database
    Dim rst As Object 'DAO.Recordset
    Dim i As Long
        
    Set dbe = CreateObject("DAO.DBEngine.120")
    Set db = dbe.OpenDatabase("C:\...\file.accdb")
    Set rst = db.TableDefs("ИмяТаблицы").OpenRecordset
        
    For i = 1 To 10 'цикл по записям Excel
        rst.AddNew
            rst("Поле1").Value = "первое поле из Excel"
            rst("Поле2").Value = "второе поле из Excel"
            rst("Поле3").Value = "третье поле из Excel"
        rst.Update
    Next
        
End Sub

Можно и на более модерновом ADO, но DAO мне исторически ближе. И меньше буковок получается в плане "строки подключения"

Для файлов c расширением mdb можно использовать Set dbe = CreateObject("DAO.DBEngine.36"). Это по поводу универсальности.


Не в чистом виде универсально, в силу ограничений провайдеров данных (не может Jet работать с xls? при Access mdb, ACE тут все яднее).

Public Sub AddNew()
    'Если хотя бы один из файлов 2007-2010, то
    'Const sConn As String = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Share Deny None;Data Source=c:\sap\db.accdb"
    Const sConn As String = "Provider=Microsoft.Jet.OLEDB.4.0;;Mode=Share Deny None;Data Source=c:\sap\db.mdb"
    Dim AddSQL As String
    Dim pConn As Object, AddRSet As Object, TableRSet As Object
    Set pConn = CreateObject("ADODB.Connection"): pConn.Open sConn
    'Поменять на Excel 12.0 для версий файлов 2007-2010 (путь и имя файла с импортируемыми в Access значениями)
    AddSQL = "Select t1.[Дата],t1.[Название],t1.[Данные] From [Excel 8.0;DATABASE=c:\SAP\book1.xls;HDR=YES].[Sheet1$] As t1"
    'Заменить TableName на название таблицы в Access
    AddSQL = AddSQL & " Left Join TableName As t2 On ((t1.[Дата]=t2.[Дата]) And (t1.[Название]=t2.[Название]) And (t1.[Данные]=t2.[Данные]))"
    AddSQL = AddSQL & " Where t2.[Дата] Is Null"
    Set AddRSet = CreateObject("ADODB.Recordset"): AddRSet.CursorLocation = 3
    AddRSet.Open AddSQL, pConn, 3, 1
    If AddRSet.RecordCount = 0 Then
        MsgBox "Нет новых записей"
    Else
        Set TableRSet = CreateObject("ADODB.Recordset"): TableRSet.CursorLocation = 3
        'Заменить TableName на название таблицы в Access
        TableRSet.Open "Select [Дата],[Название],[Данные] From TableName Where [Дата] Is Null", pConn, 3, 3
        Do Until AddRSet.EOF
            TableRSet.AddNew
            TableRSet("Дата").Value = AddRSet("Дата").Value
            TableRSet("Название").Value = AddRSet("Название").Value
            TableRSet("Данные").Value = AddRSet("Данные").Value
            AddRSet.MoveNext
        Loop
        TableRSet.Update
        TableRSet.Close
    End If
    AddRSet.Close: pConn.Close
End Sub


Начал с кода Константина, потому что его код визуально меньше

Подправил с учётом расположений файлов, получилось так:

Sub fromExcelToAccess()
    Dim dbe As Object 'DAO.DBEngine
    Dim db  As Object 'DAO.Database
    Dim rst As Object 'DAO.Recordset
    Dim i As Long
        
    Set dbe = CreateObject("DAO.DBEngine.120")
    Set db = dbe.OpenDatabase("C:\...\Test.accdb")
    Set rst = db.TableDefs("Таблица1").OpenRecordset
        
    For i = 1 To Range("A" & Cells.Rows.Count).End(xlUp).Row - 1
            rst.AddNew
            rst("Поле1").Value = Range("a" & 1 + i).Value
            rst("Поле2").Value = Range("b" & 1 + i).Value
            rst("Поле3").Value = Range("c" & 1 + i).Value
        rst.Update
    Next
        
End Sub



Код работает правильно, но позволяет заливать одинаковые данные сколько угодно раз. Как этого избежать?


Сделать поле1 и поле2 в Access ключевыми


ну и в коде надо будет еще Update обернуть обработкой ошибки:
    On Error Resume Next
    rst.Update
    On Error GoTo 0

Я так обычно делаю, а кто-то в начале процедуры пишет только первый оператор.


Например, такой перебор записей набора с учетом фильтра (WHERE):

Sub traverseRecordset()
    Dim dbe As Object 'DAO.DBEngine
    Dim db  As Object 'DAO.Database
    Dim rst As Object 'DAO.Recordset
        
    Set dbe = CreateObject("DAO.DBEngine.120")
    Set db = dbe.OpenDatabase("C:\...\file.accdb")
    Set rst = db.OpenRecordset("SELECT * FROM Таблица1 WHERE 1=1")
        
    Do While Not rst.EOF 'цикл по записям
    
        'бла-бла-бла: что-то делаем с очередной записью
        'например, "трогаем" значение первого поля
        Debug.Print rst.Fields(0).Value
        
        rst.MoveNext
    Loop
        
End Sub


Цитата

Я думал что можно как-то сверять данные на листе и данные в БД блоком


В виде SQL запроса можно, как вариант к версии, выбирающий записи в таблице и листе по совпадению трёх полей


    ExistsSQL = "Select t1.[Дата],t1.[Название],t1.[Данные] From [Excel 8.0;DATABASE=c:\SAP\book1.xls;HDR=YES].[Sheet1$] As t1"
    ExistsSQL = ExistsSQL & " Inner Join TableName As t2 On ((t1.[Дата]=t2.[Дата]) And (t1.[Название]=t2.[Название]) And (t1.[Данные]=t2.[Данные]))"
    Set ExistsRSet = CreateObject("ADODB.Recordset"): ExistsRSet.CursorLocation = 3
    ExistsRSet.Open ExistsSQL, pConn, 3, 1
    If ExistsRSet.RecordCount > 0 Then
        Set pSheet = ActiveWorkbook.Worksheets
        pSheet.Range("A1:C1").Value = Array("Дата", "Название", "Данные")
        pSheet.Range("A2").CopyFromRecordset ExistsRSet
        MsgBox "Создан лист дубликатов"
    End If
    ExistsRSet.Close


Собственно, почти тоже самое используется в запросе на добавление AddSQL для отбора с листа записей, которые по всем трём полям не совпадают с существующими в таблице.

По поводу первичного ключа. У вас же товар приходит по какой-то накладной или нечто подобное. Её и можно добавить в качестве элемента ключа: дата, название, накладная.
Или вариант: дата, название, время ввода в таблицу.
Или некоторое строковое значение - код ввода, получаемое как запрос к FileSystemObject.GetTempName: дата, название, кодВвода

Public Function GetPKey()
    Dim fso As Object, sKey As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    sKey = fso.GetTempName
    GetPKey = Mid$(sKey, 1, Len(sKey) - 4)
End Function

Хочу обратить внимание, что метод CopyFromRecordset объекта Range работает и в случае DAO (а не только ADO):

Цитата

Excel Developer Reference
Range.CopyFromRecordset Method
Copies the contents of an ADO or DAO Recordset object onto a worksheet, beginning at the upper-left corner of the specified range.



Поэтому можно отобранные аксессные строки выгрузить на лист Excel:

Sub fromRecordset()

    Dim dbe As Object 'DAO.DBEngine
    Dim db  As Object 'DAO.Database
    Dim rst As Object 'DAO.Recordset
        
    Set dbe = CreateObject("DAO.DBEngine.120")
    Set db  = dbe.OpenDatabase("C:\...\file.accdb")
    Set rst = db.OpenRecordset("SELECT * FROM Таблица1 WHERE 1=1")
    Range("A1").CopyFromRecordset rst          
        
End Sub


А потом просто операцией присваивания передать диапазон выгрузки в массив VBA - ну, а дальше уже, как говорится, дело техники и фантазии.


Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования