Excel VBA SQL 记录集不刷新

Question

我正在运行对 excel table 进行 SQL 查询：Table1。查询运行第一次执行时没问题。但后来，在对 Table1 进行一些更改后，当完全相同的 SQL 查询为运行时，它会继续返回与第一次获取的相同的值。

无论我做什么，它只会在我完全关闭 excel 并再次打开时 'reset'。我假设连接或记录集发生了某些事情，但我看不到问题所在。有人可以看一下并告诉我哪里出了问题吗？

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

Answer 1

好的，解决方案就像添加 ThisWorkbook.Save 一样简单。谢谢 Vityata、CLR 和 Harassed Dad，是你们救了我。

Answer 2

考虑使用 QueryTables，它与 ListObjects 接口，可以直接运行对 SQL 查询，每次刷新。通过这种方式，您可以避免 ADO 连接和记录集 objects 甚至构建列 headers.

的需要

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")).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

Excel VBA SQL 记录集不刷新

Excel VBA SQL recordset doesn't refresh

sql

excel

vba

ado