Передача данных из открытого листа Excel в Access VBA? - PullRequest
Новая
       38

Передача данных из открытого листа Excel в Access VBA?

0 голосов
/ 25 октября 2018

У нас есть шаблон Excel, который предоставляется нам, и частью нашего процесса является загрузка всех вариантов этого шаблона в базу данных доступа, чтобы упростить просмотр данных.Мы создали макрос в базе данных доступа, чтобы помочь нам с проверкой всех данных в больших масштабах.

Текущий макрос открывает файл Excel, просматривает циклы и пересчитывает их на основе различных параметров, затем сохраняет файл ипередает его в базу данных.Я сохраняю файл открытым до тех пор, пока все передачи не будут выполнены, чтобы сэкономить сетевое время.

В настоящее время я выполняю это с помощью приведенного ниже кода, но получаю нежелательный результат, вызов вставки в доступ открывает другой экземпляр Excel столько для чтения версия того же файла.Похоже, что-то еще сделать позже с этим файлом.Есть идеи относительно этого поведения?Или есть лучший способ сделать это, если файл Excel уже открыт?Спасибо !!!

Редактировать: Это на самом деле не работает, как я надеялся.Второй открывающийся экземпляр никогда не изменяется, и кажется, что оператор вставки JET продолжает ссылаться на файл только для чтения, а не на экземпляр Excel, который у меня открыт.

Jay 

Sub enumerateForm()

'Create Excel application
Dim appExcel As Excel.Application
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True

'Open Form Template
wbFormTemplate = "7.31 Form 2017EY.xlsm"
Dim wbbasefile As Excel.Workbook
Set wbbasefile = appExcel.Workbooks.Open(wbFormTemplate, True, False)

 'Dim wsctrl As Excel.Worksheet
 Dim rsCubeFilters As DAO.Recordset

 Dim Cube1Val(1 To 111) As String
 Dim Cube2Val(1 To 111) As String
 Dim Cube1filter As String
 Dim cube2filter As String
 Dim filterSheet As String

'Set recordsets for the loops. This is grabbing all the pivot filters for the enumeration process
Set rsCubeFilters = CurrentDb.OpenRecordset("SELECT * FROM [Cube1Values] WHERE [Filing] = 'HHS'")


'Loops through all Enumerations
Do While rsCubeFilters.EOF = False
    'Empty the array for the cube filter
    Erase Cube1Val
    Erase Cube2Val
    filterSheet = "Pt 1 Summary of Data"

    'Cube 1 Filter Update (Situs State)
    Cube1filter = rsCubeFilters(1).Value
    wbbasefile.Sheets(filterSheet).PivotTables(filterSheet).PivotFields(Cube1filter).ClearAllFilters
    wbbasefile.Sheets(filterSheet).PivotTables(filterSheet).CubeFields(37).EnableMultiplePageItems = True
    Cube1Val(1) = rsCubeFilters(2).Value
    wbbasefile.Sheets(filterSheet).PivotTables(filterSheet).PivotFields(Cube1filter).VisibleItemsList = Array(Cube1Val)

    'Cube 2 Filter Update (Legal Entity)
    cube2filter = rsCubeFilters(3).Value
    wbbasefile.Sheets(filterSheet).PivotTables(filterSheet). _ 
PivotFields(cube2filter).ClearAllFilters
wbbasefile.Sheets(filterSheet).PivotTables(filterSheet) _
.CubeFields(11).EnableMultiplePageItems = True
Cube2Val(1) = rsCubeFilters(4).Value
wbbasefile.Sheets(filterSheet).PivotTables(filterSheet).PivotFields(cube2filter).VisibleItemsList = Array(Cube2Val)

'Refresh All Cubes
appExcel.Calculation = xlCalculationAutomatic
wbbasefile.RefreshAll
appExcel.CalculateUntilAsyncQueriesDone

wbbasefile.Save

Dim rsExcelRanges As DAO.Recordset
Dim conn As ADODB.Connection

Set rsExcelRanges = CurrentDb.OpenRecordset("SELECT * FROM [Excel Ranges] WHERE [Filing] = 'HHS'")
Set cn = CreateObject("ADODB.Connection")
 ssql = "INSERT INTO [" & rsExcelRanges(3).Value & "] "
  ssql = ssql & "SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & wbFormTemplate & "].[" & rsExcelRanges(1).Value & "$" & rsExcelRanges(2).Value & "]"

  CurrentDb.Execute ssql

rsCubeFilters.MoveNext
Loop

1 Ответ

0 голосов
/ 25 октября 2018

После того, как ваш код завершит проверку файла Excel и сохранит его, вам нужно будет закрыть файл, чтобы выпустить его для редактирования.Просто добавьте несколько строк кода, чтобы закрыть книгу и выйти из приложения Excel.Тогда ваш запрос откроет файл для чтения-записи. 

...
'Refresh All Cubes
appExcel.Calculation = xlCalculationAutomatic
wbbasefile.RefreshAll
appExcel.CalculateUntilAsyncQueriesDone

wbbasefile.Save
wbbasefile.Close
appExcel.quit 

Dim rsExcelRanges As DAO.Recordset
Dim conn As ADODB.Connection

Set rsExcelRanges = CurrentDb.OpenRecordset("SELECT * FROM [Excel Ranges] WHERE [Filing] = 'HHS'")
Set cn = CreateObject("ADODB.Connection")
...
...