Набор записей Excel VBA SQL не обновляется - PullRequest
Новая
       12

Набор записей Excel VBA SQL не обновляется

0 голосов
/ 03 мая 2018

Я выполняю SQL-запрос к таблице Excel: Table1 . Запрос выполняется нормально при первом выполнении. Но позже, после некоторых изменений в Table1 , когда выполняется тот же SQL-запрос, он продолжает возвращать те же значения, которые были получены в первый раз.

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

Sub createConsolidatedTable()

Dim conn As Object, rs As Object
Dim tbl As ListObject
Dim icols As Integer

Application.Calculate

ThisWorkbook.Sheets("Temp2").Cells.Clear

With ThisWorkbook.Sheets("Temp1")
    .Calculate
    Set tbl = .ListObjects("Table1")
End With

Set conn = CreateObject("ADODB.Connection")

With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
    "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
    .Open
End With

On Error GoTo CloseConnection

Set rs = CreateObject("ADODB.Recordset")

With rs
    .ActiveConnection = conn
    .CursorType = adOpenKeyset
    .Source = getSQL(tbl)
    .Open
End With

With ThisWorkbook.Sheets("Temp2") 'Destination
    For icols = 0 To rs.Fields.Count - 1
        .Cells(1, icols + 1).Value = rs.Fields(icols).Name
    Next
    .Range("A2").CopyFromRecordset rs 'Create table with new data
    .ListObjects.Add(SourceType:=xlSrcRange, _
            Source:=.Range("A1").CurrentRegion, _
            XlListObjectHasHeaders:=xlYes, _
            TableStyleName:=tbl.TableStyle).Name = "Table2"
End With


CloseRecordset:
    rs.Close
    Set rs = Nothing

CloseConnection:
    conn.Close
    Set conn = Nothing

    Debug.Print "Finished table creation"

End Sub

Function getSQL(tbl As ListObject) As String
    ' create sql instruction
    Dim SQL As String, SheetName As String, RangeAddress As String
        SQL = "SELECT [Business Area], [Company Type], [SOURCE], [Customer Country], [Product], [Segment]" & _
            ", [Ship Year], [Ship 6M], [Ship 3M]" & _
            ", Sum([Quantity]) AS [Sum Quantity], Sum([Amount LCY]) AS [Sum Amount LCY]" & _
            ", Sum([Out Amount LCY]) AS [Sum Out Amount LCY], Sum([Profit]) AS [Sum Of Profit]" & _
            ", Sum([Out Profit LCY]) AS [Sum Out Profit LCY], [Finished Product]" & _
        " FROM [SheetName$RangeAddress]" & _
            " GROUP BY [Business Area], [Company Type], [SOURCE], [Customer Country], [Product], [Segment]" & _
            ", [Ship Year], [Ship 6M], [Ship 3M], [Finished Product]" & _
        " Union ALL" & _
        " SELECT [Business Area], [Company Type], [SOURCE], [Customer Country], [Product], [Segment]" & _
            ", NULL, NULL, NULL" & _
            ", Sum([Quantity]) AS [Sum Quantity], Sum([Amount LCY]) AS [Sum Amount LCY]" & _
            ", Sum([Out Amount LCY]) AS [Sum Out Amount LCY]" & _
            ", Sum([Profit]) AS [Sum Of Profit]" & _
            ", Sum([Out Profit LCY]) AS [Sum Out Profit LCY], NULL" & _
        " FROM [SheetName$RangeAddress] WHERE [SOURCE]='BACKLOG'" & _
        " GROUP BY [Business Area], [Company Type], [SOURCE], [Customer Country], [Product], [Segment];"

    SheetName = tbl.Parent.Name
    RangeAddress = tbl.Range.Address(False, False)
    SQL = Replace(SQL, "SheetName", SheetName)
    SQL = Replace(SQL, "RangeAddress", RangeAddress)
    getSQL = SQL

End Function

Ответы [ 2 ]

0 голосов
/ 03 мая 2018

Рассмотрите возможность использования QueryTables , которые взаимодействуют с объектами ListObjects и могут напрямую запускаться для запросов SQL, каждый раз обновляясь. Таким образом, вы можете избежать необходимости подключения ADO и объектов набора записей и даже создания заголовков столбцов. 

Sub BuildQueryTable()
On Error GoTo ErrHandle
    Dim constr As String
    Dim tbl As ListObject

    Application.Calculate

    With ThisWorkbook.Sheets("Temp1")
        .Calculate
        Set tbl = .ListObjects("Table1")
    End With

    With ThisWorkbook.Sheets("Temp2")
        .Cells.Clear
        .Activate
    End With

    constr = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;" _
               & "Data Source=" & ThisWorkbook.FullName & ";" _
               & "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

    With ThisWorkbook.Sheets("Temp2").ListObjects.Add(SourceType:=0, _
                                           Source:=constr, _
                                           Destination:=Range("$A$1")).QueryTable        
         .CommandText = getSQL(tbl) 
         .ListObject.DisplayName = "Table2" 
         .Refresh BackgroundQuery:=False 
    End With

ExitHandle:
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
    Resume ExitHandle
End Sub

Function getSQL(tbl As ListObject) As String
   ' same as before ...
End Function
0 голосов
/ 03 мая 2018

Хорошо, решение было таким же простым, как добавление ThisWorkbook.Save. Спасибо Витя, CLR и Harassed Dad, вы спасли меня.

...