Как исправить этот код?Он записывает в файл первый аргумент, а не второй? - PullRequest
Новая
       16

Как исправить этот код?Он записывает в файл первый аргумент, а не второй?

0 голосов
/ 28 мая 2019

Я работаю над этим кодом, чтобы автоматизировать «копирование-вставку» путем чтения из таблицы доступа и записи в таблицу Excel. Различные значения из таблицы доступа, должны быть записаны в определенных ячейках на листе Excel. Моя проблема в том, что код работает, читая и записывая первое значение, но не второе значение ++.

Первое значение правильно записано на E15 в Excel, но второе значение, которое предполагается записать в ячейку E16, не записано. Почему? 

Sub HentData()

Dim cn As Object, rs As Object
Dim intColIndex As Integer
Dim DBFullName As String
Dim TargetRange As Range
Dim Sum As Double

DBFullName = "C:\saga_effekt_Nidaros_2017_tiltak.mdb"

Application.ScreenUpdating = False

Set TargetRange = Sheets("1.3 Persontransportmodell").Range("A1")

Set cn = CreateObject("ADODB.Connection")

cn.Open "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)};DBQ=C:\saga_effekt_Nidaros_2017_tiltak.mdb;"

Set rs = CreateObject("ADODB.Recordset")

rs.Open "SELECT [VERDI] FROM [saga_trafikantnytte] WHERE [REISEMIDDE] = 'tog' AND [VARIABEL] = 'sum'", cn, , , adCmdText

For intColIndex = 0 To rs.Fields.Count - 1
    'TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
    Next

TargetRange.Offset(14, 4).CopyFromRecordset rs

 Application.ScreenUpdating = True

    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    On Error GoTo 0
    Exit Sub

rs.Open "SELECT [VERDI] FROM [saga_trafikantnytte] WHERE [REISEMIDDE] = 'tog' AND [VARIABEL] = 'referansetrafikk'", cn, , , adCmdText

For intColIndex = 0 To rs.Fields.Count - 1
    'TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
    Next

TargetRange.Offset(15, 4).CopyFromRecordset rs

 Application.ScreenUpdating = True

    On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    On Error GoTo 0
    Exit Sub

End Sub

Я не получаю никаких сообщений об ошибках, код выполняется, но вывод не завершен.

Ответы [ 2 ]

0 голосов
/ 28 мая 2019

Вот редактирование вашего исходного кода, который должен работать.Не было нужды звонить первым Exit Sub.Второе также было ненужным, так как у вас не было кода обработки ошибок.

Кроме того, вам не нужно закрывать соединение или сбрасывать rs до конца. 

Sub HentData()

Dim cn As Object, rs As Object
Dim intColIndex As Integer
Dim DBFullName As String
Dim TargetRange As Range
Dim Sum As Double

DBFullName = "C:\saga_effekt_Nidaros_2017_tiltak.mdb"
Application.ScreenUpdating = False
Set TargetRange = Sheets("1.3 Persontransportmodell").Range("A1")

Set cn = CreateObject("ADODB.Connection")
cn.Open "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)};DBQ=C:\saga_effekt_Nidaros_2017_tiltak.mdb;"

Set rs = CreateObject("ADODB.Recordset")
rs.Open "SELECT [VERDI] FROM [saga_trafikantnytte] WHERE [REISEMIDDE] = 'tog' AND [VARIABEL] = 'sum'", cn, , , adCmdText

For intColIndex = 0 To rs.Fields.Count - 1
    'TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
Next
TargetRange.Offset(14, 4).CopyFromRecordset rs
Application.ScreenUpdating = True

On Error Resume Next
rs.Close
On Error GoTo 0

rs.Open "SELECT [VERDI] FROM [saga_trafikantnytte] WHERE [REISEMIDDE] = 'tog' AND [VARIABEL] = 'referansetrafikk'", cn, , , adCmdText

For intColIndex = 0 To rs.Fields.Count - 1
    'TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
Next
TargetRange.Offset(15, 4).CopyFromRecordset rs
Application.ScreenUpdating = True

On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
On Error GoTo 0

End Sub
0 голосов
/ 28 мая 2019

Попробуйте это: 

range(cells(15,4), cells(15,3+rs.Fields.Count)).CopyFromRecordset rs
...