gpt4 book ai didi

sql - excel vba - 在电子表格上查询

转载 作者:行者123 更新时间:2023-12-03 13:49:07 28 4
gpt4 key购买 nike

如果我有这两张 table :

source

target

sql

result

是否有某种 excel vba 代码(使用 ADO)可以实现这些期望的结果,这些结果可以利用我在 SQL 表中输入的任何查询?
progress

最佳答案

下面是一些 VBA 代码,可让您使用文本 SQL 驱动程序读取 Excel 范围。这是一个相当复杂的例子,但我猜你来到这里是因为你是一个相当高级的用户,但问题比我们在其他网站上看到的例子更复杂。
在我完整发布代码之前,这是核心函数中原始的“示例用法”注释, FetchXLRecordSet :

' Sample usage:
'
' Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap")
'
' Where the query uses two named ranges, "TableAccountLookup" and "TableCashMap"
' as shown in this SQL statement:
'
' SELECT
' B.Legal_Entity_Name, B.Status,
' SUM(A.USD_Settled) As Settled_Cash
' FROM
' [TableAccountLookup] AS A,
' [TableCashMap] AS B
' WHERE
' A.Account IS NOT NULL
' AND B.Cash_Account IS NOT NULL
' AND A.Account = B.Cash_Account
' GROUP BY
' B.Legal_Entity_Name,
' B.Status
它很笨重,迫使您在运行查询时命名表(或完整列出范围地址),但它简化了代码。
Option Explicit
Option Private Module

' ADODB data retrieval functions to support Excel
' Online reference for connection strings:
' http://www.connectionstrings.com/oracle#p15
' Online reference for ADO objects & properties:
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
' External dependencies:
' Scripting - C:\Program files\scrrun.dll
' ADO - C:\Program files\Common\system\ado\msado27.tlb

Private m_strTempFolder As String
Private m_strConXL As String
Private m_objConnXL As ADODB.Connection


Public Property Get XLConnection() As ADODB.Connection
On Error GoTo ErrSub

' The Excel database drivers have memory problems so we use the text driver
' to read csv files in a temporary folder. We populate these files from
' ranges specified for use as tables by the FetchXLRecordSet() function.

Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject
Set m_objConnXL = New ADODB.Connection

' Specify and clear a temporary folder:
m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
m_strTempFolder = m_strTempFolder & "XLSQL"
Application.DisplayAlerts = False
If objFSO.FolderExists(m_strTempFolder) Then
objFSO.DeleteFolder m_strTempFolder
End If
If Not objFSO.FolderExists(m_strTempFolder) Then
objFSO.CreateFolder m_strTempFolder
End If
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If

' JET OLEDB text driver connection string:
' Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited";
' ODBC text driver connection string:
' Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
m_strConXL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";"
m_strConXL = m_strConXL & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1" & Chr(34) & ";"

With m_objConnXL
.CursorLocation = adUseClient
.CommandTimeout = 90
.ConnectionString = m_strConXL
.Mode = adModeRead
End With

If m_objConnXL.State = adStateClosed Then
Application.StatusBar = "Connecting to the local Excel tables"
m_objConnXL.Open
End If

Set XLConnection = m_objConnXL

ExitSub:
Application.StatusBar = False
Exit Property

ErrSub:
MsgPopup "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10
Resume ErrEnd
' Resume ExitSub

ErrEnd:
End ' Terminal error. Halt.

End Property


Public Sub CloseConnections()

On Error Resume Next
Set m_objConnXL = Nothing

End Sub


Public Function FetchXLRecordSet(ByVal SQL As String, ParamArray TableNames()) As ADODB.Recordset

' This allows you to retrieve data from Excel ranges using SQL. You
' need to pass additional parameters specifying each range you're using as a table
' so that the these ranges can be saved as csv files in the 'XLSQL' temporary folder
' Note that your query must use the 'table' naming conventions required by the Excel
' database drivers: http://www.connectionstrings.com/excel#20

On Error Resume Next

Dim i As Integer
Dim iFrom As Integer
Dim strRange As String
Dim j As Integer
Dim k As Integer

If IsEmpty(TableNames) Then
TableNames = Array("")
End If

If InStr(TypeName(TableNames), "(") < 1 Then
TableNames = Array(TableNames)
End If

Set FetchXLRecordSet = New ADODB.Recordset

With FetchXLRecordSet
.CacheSize = 8
Set .ActiveConnection = XLConnection
iFrom = InStr(8, SQL, "From", vbTextCompare) + 4

For i = LBound(TableNames) To UBound(TableNames)
strRange = ""
strRange = TableNames(i)
If strRange = "0" Or strRange = "" Then
j = InStr(SQL, "FROM") + 4
j = InStr(j, SQL, "[")
k = InStr(j, SQL, "]")
strRange = Mid(SQL, j + 1, k - j - 1)
End If
RangeToFile strRange
SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1)
SQL = Replace(SQL, "$.csv", ".csv")
SQL = Replace(SQL, ".csv$", ".csv")
SQL = Replace(SQL, ".csv.csv", ".csv")
Next i

.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Connecting to the database" & String(i, ".")
Sleep 250
Loop

End With

Application.StatusBar = False

End Function


Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String
' Read a range into a string.
' Each row is delimited with a carriage-return and a line break.
' Empty cells are concatenated into the string as 'Tabs' of four spaces.
'NH Feb 2018: you cannot return more than 32767 chars into a range.

Dim i As Integer
Dim j As Integer
Dim arrCells As Variant
Dim arrRows() As String
Dim arrRowX() As String
Dim strRow As String
Dim boolIndent As Boolean

Const SPACE As String * 1 = " "
Const SPACE4 As String * 4 = " "
Const MAX_LEN As Long = 32767

arrCells = SQL_Range.Value2

If InStr(TypeName(arrCells), "(") Then

ReDim arrRows(LBound(arrCells, 1) To UBound(arrCells, 1))
ReDim arrRowX(LBound(arrCells, 2) To UBound(arrCells, 2))

For i = LBound(arrCells, 1) To UBound(arrCells, 1) - 1
boolIndent = True

For j = LBound(arrCells, 2) To UBound(arrCells, 2)
If isError(arrCells(i, j)) Then
SQL_Range(i, j).Calculate
End If
If Not isError(arrCells(i, j)) Then
arrRowX(j) = arrCells(i, j)
Else
arrRowX(j) = vbNullString
End If
If boolIndent And arrRowX(j) = "" Then
arrRowX(j) = SPACE4
Else
boolIndent = False
End If
Next j

arrRows(i) = Join(arrRowX, SPACE)

If Len(Trim$(arrRows(i))) = 0 Then
arrRows(i) = vbNullString
Else
arrRows(i) = RTrim$(Join(arrRowX, SPACE))
End If

Next i

Erase arrCells
Erase arrRowX
ReadRangeSQL = Join(arrRows, vbCrLf)
Erase arrRows
ReadRangeSQL = Replace(ReadRangeSQL, vbCrLf & vbCrLf, vbCrLf)

Else
ReadRangeSQL = CStr(arrCells)
End If

If Len(ReadRangeSQL) > MAX_LEN Then
' Trip terminating spaces from each row:
Do While InStr(1, ReadRangeSQL, SPACE & vbCrLf, vbBinaryCompare) > 0
ReadRangeSQL = Replace(ReadRangeSQL, SPACE & vbCrLf, vbCrLf)
Loop
End If

If Len(ReadRangeSQL) > MAX_LEN Then
' Reduce the 'tab' size to 2 selectively, after each row's indentation
arrRows = Split(ReadRangeSQL, vbCrLf)
For i = LBound(arrRows) To UBound(arrRows)
If Len(arrRows(i)) > 16 Then
If InStr(12, arrRows(i), SPACE4) > 0 Then
arrRows(i) = Left$(arrRows(i), 12) & Replace(Right$(arrRows(i), Len(arrRows(i)) - 12), SPACE4, SPACE & SPACE)
End If
End If
Next i

ReadRangeSQL = Join(arrRows, vbCrLf)
Erase arrRows
End If

If Len(ReadRangeSQL) > MAX_LEN Then
' Reduce the 'tab' size to 2 indiscriminately. This will make your SQL illegible:
Do While InStr(1, ReadRangeSQL, SPACE4, vbBinaryCompare) > 0
ReadRangeSQL = Replace(ReadRangeSQL, SPACE4, SPACE & SPACE)
Loop
End If

End Function


Public Sub RangeToFile(ByRef strRange As String)
' Output a range to a csv file in a temporary folder created by the XLConnection function
' strRange specifies a range in the current workbook using the 'table' naming conventions
' specified for Excel OLEDB database drivers: http://www.connectionstrings.com/excel#20
' The first row of the range is assumed to be a set of column names.

On Error Resume Next

Dim objFSO As Scripting.FileSystemObject
Dim rng As Excel.Range
Dim strFile As String
Dim arrData As Variant
Dim iRow As Long
Dim jCol As Long
Dim strData As String
Dim strLine As String

strRange = Replace(strRange, "[", "")
strRange = Replace(strRange, "]", "")

If Right(strRange, 1) = "$" Then
strRange = Replace(strRange, "$", "")
Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
Else
strRange = Replace(strRange, "$", "")
Set rng = Range(strRange)
If rng Is Nothing Then
Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
End If
End If

If rng Is Nothing Then
Exit Sub
End If

Set objFSO = New Scripting.FileSystemObject
strFile = m_strTempFolder & strRange & ".csv"

If objFSO.FileExists(strFile) Then
objFSO.DeleteFile strFile, True
End If

If objFSO.FileExists(strFile) Then
Exit Sub
End If

arrData = rng.Value2

With objFSO.OpenTextFile(strFile, ForWriting, True)

' Header row:
strLine = ""
strData = ""

iRow = LBound(arrData, 1)

For jCol = LBound(arrData, 2) To UBound(arrData, 2)
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
strData = strData & ","
strLine = strLine & strData
Next jCol

strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.WriteLine strLine
End If

' Rest of the data
For iRow = LBound(arrData, 1) + 1 To UBound(arrData, 1)

strLine = ""
strData = ""

For jCol = LBound(arrData, 2) To UBound(arrData, 2)
If IsError(arrData(iRow, jCol)) Then
strData = "#ERROR"
Else
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
strData = Replace(strData, Chr(9), " ")
strData = Trim(strData)
End If

strData = Chr(34) & strData & Chr(34) & "," ' Quotes to coerce all values to text
strLine = strLine & strData
Next jCol

strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.WriteLine strLine
End If

Next iRow

.Close
End With ' textstream object from objFSO.OpenTextFile

Set objFSO = Nothing
Erase arrData
Set rng = Nothing

End Sub
最后,将 Recordset 写入 Range - 如果不是针对您必须处理的所有错误,代码将是微不足道的:
Public Sub RecordsetToRange(rngTarget As Excel.Range, objRecordset As ADODB.Recordset, Optional FieldList As Variant, Optional ShowFieldNames As Boolean = False, Optional Orientation As Excel.XlRowCol = xlRows)

' Write an ADO Recordset to an Excel range in a single 'hit' to the sheet
' Calling function is responsible for setting the record pointer (must not be EOF!)
' The target range is resized automatically to the dimensions of the array, with the top left cell used as the start point.

On Error Resume Next

Dim OutputArray As Variant
Dim i As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim varField As Variant

If objRecordset Is Nothing Then
Exit Sub
End If

If objRecordset.State <> 1 Then
Exit Sub
End If

If objRecordset.BOF And objRecordset.EOF Then
Exit Sub
End If

If Orientation = xlColumns Then
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
OutputArray = objRecordset.GetRows
Else
OutputArray = objRecordset.GetRows(Fields:=FieldList)
End If
Else
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
OutputArray = ArrayTranspose(objRecordset.GetRows)
Else
OutputArray = ArrayTranspose(objRecordset.GetRows(Fields:=FieldList))
End If
End If

ArrayToRange rngTarget, OutputArray

If ShowFieldNames Then

If Orientation = xlColumns Then

ReDim OutputArray(LBound(OutputArray, 1) To UBound(OutputArray, 1), 1 To 1)
iRow = LBound(OutputArray, 1)

If IsEmpty(FieldList) Or IsMissing(FieldList) Then

For i = 0 To objRecordset.Fields.Count - 1
If i > UBound(OutputArray, 1) Then
Exit For
End If
OutputArray(iRow + i, 1) = objRecordset.Fields(i).Name
Next i

Else

If InStr(TypeName(FieldList), "(") < 1 Then
FieldList = Array(FieldList)
End If
i = 0
For Each varField In FieldList
OutputArray(iRow + i, 1) = CStr(varField)
i = i = 1

Next

End If 'IsEmpty(FieldList) Or IsMissing(FieldList)

ArrayToRange rngTarget.Cells(1, 0), OutputArray

Else

ReDim OutputArray(1 To 1, LBound(OutputArray, 2) To UBound(OutputArray, 2))
iCol = LBound(OutputArray, 2)

If IsEmpty(FieldList) Or IsMissing(FieldList) Then

For i = 0 To objRecordset.Fields.Count - 1
If i > UBound(OutputArray, 2) Then
Exit For
End If
OutputArray(1, iCol + i) = objRecordset.Fields(i).Name
Next i

Else

If InStr(TypeName(FieldList), "(") < 1 Then
FieldList = Array(FieldList)
End If
i = 0
For Each varField In FieldList
OutputArray(1, iCol + i) = CStr(varField)
i = i = 1
Next

End If ' IsEmpty(FieldList) Or IsMissing(FieldList)

ArrayToRange rngTarget.Cells(0, 1), OutputArray

End If ' Orientation = xlColumns

End If 'ShowFieldNames

Erase OutputArray

End Sub


Public Function ArrayTranspose(InputArray As Variant) As Variant
' Transpose InputArray.
' Returns InputArray unchanged if it is not a 2-Dimensional Variant(x,y)

Dim iRow As Long
Dim iCol As Long
Dim iRowCount As Long
Dim iColCount As Long
Dim boolNoRows As Boolean
Dim BoolNoCols As Boolean
Dim OutputArray As Variant

If IsEmpty(InputArray) Then
ArrayTranspose = InputArray
Exit Function
End If

If InStr(1, TypeName(InputArray), "(") < 1 Then
ArrayTranspose = InputArray
Exit Function
End If

' Check that we can read the array's dimensions:
On Error Resume Next

Err.Clear
iRowCount = 0
iRowCount = UBound(InputArray, 1)

If Err.Number <> 0 Then
boolNoRows = True
End If

Err.Clear
Err.Clear
iColCount = 0
iColCount = UBound(InputArray, 2)

If Err.Number <> 0 Then
BoolNoCols = True
End If

Err.Clear

If boolNoRows Then

' ALL arrays have a defined Ubound(MyArray, 1)!
' This variant's dimensions cannot be determined
OutputArray = InputArray

ElseIf BoolNoCols Then

' It's a vector. Strictly speaking, a vector cannot be 'transposed', as
' calling the ordinal a 'row' or a 'column' is arbitrary or meaningless.
' But... By convention, Excel users regard a vector as an array of 1 to n
' rows and 1 column. So we'll 'transpose' it into a Variant(1 to 1, 1 to n)
ReDim OutputArray(1 To 1, LBound(InputArray, 1) To UBound(InputArray, 1))

For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
OutputArray(1, iRow) = InputArray(iRow)
Next iRow

Else

ReDim OutputArray(LBound(InputArray, 2) To UBound(InputArray, 2), LBound(InputArray, 1) To UBound(InputArray, 1))

If IsEmpty(OutputArray) Then
ArrayTranspose = InputArray
Exit Function
End If

If InStr(1, TypeName(OutputArray), "(") < 1 Then
ArrayTranspose = InputArray
Exit Function
End If

For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
OutputArray(iCol, iRow) = InputArray(iRow, iCol)
Next iCol
Next iRow

End If

ExitFunction:
ArrayTranspose = OutputArray
Erase OutputArray
End Function
后记:在 Excel '表' 对象上运行 SQL
为了完整起见,这是一个准系统“使用 SQL 读取 Excel 表对象”函数的代码,该函数在后台处理所有文本文件黑客攻击。
我现在发布它,在我原来的答案出现一段时间后,因为每个人都在 Excel 中使用丰富的“表格”对象来制作表格数据:

' Run a JOIN query on your tables, and write the field names and data to Sheet1:
SaveTable "Table1"
SaveTable "Table2"
SQL= SQL & "SELECT * "
SQL= SQL & " FROM Table1 "
SQL= SQL & " LEFT JOIN Table2 "
SQL= SQL & " ON Table1.Client = Table2.Client"
RunSQL SQL, Sheet1.Range("A1")
...完整列表(在前面的代码转储中提供或获取几个函数)是:
Public Function RunSQL(SQL As String, TargetRange As Excel.Range, Optional DataSetName As String) 

' Run SQL against table files in the local ExcelSQL folder and write the results to a target range
' The full implementation of ExcelSQL provides a fully-featured UI on a control sheet
' This is a cut-down version which runs everything automatically, without audit & error-reporting
' SQL can be read from ranges using the ReadRangeSQL function
' If no target range object is passed in, and a Data set name is specified, the recordset will be
' saved as [DataSetName].csv in the local Excel SQL folder for subsequent SQL queries
' If no target range is specified and no Data set name specified, returns the recordet object

Dim rst As ADODB.Recordset

If Left(SQL, 4) = "SQL_" Then
SQL = ReadRangeSQL(ThisWorkbook.Names(SQL).RefersToRange)
End If

Set rst = FetchTextRecordset(SQL)

If TargetRange Is Nothing Then
If DataSetName = "" Then
Set RunSQL = rst
Else
RecordsetToCSV rst, DataSetName, , , , , , , False
Set rst = Nothing
End If
Else
RecordsetToRange rst, TargetRange, True
Set rst = Nothing
End If

End Function


Public Function FetchTextRecordset(SQL As String) As ADODB.Recordset
' Fetch records from the saved text files in the Temp SQL Folder:
On Error Resume Next

Dim i As Integer
Dim iFrom As Integer

If InStr(1, connText, "IMEX=1", vbTextCompare) > 0 Then SetSchema
Set FetchTextRecordset = New ADODB.Recordset

With FetchTextRecordset

.CacheSize = 8
Set .ActiveConnection = connText
On Error GoTo ERR_ADO
.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0

Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Waiting for data" & String(i, ".")
Application.Wait Now + (0.25 / 24 / 3600)
Loop

End With

Application.StatusBar = False

ExitSub:
Exit Function

ERR_ADO:
Dim strMsg
strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the developer, or " & SUPPORT & "."

If Verbose Then
MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext
End If
Resume ExitSub

Exit Function

' Try this if SQL is too big to debug in the immediate window:
' FSO.OpenTextFile("C:\Temp\SQL.txt",ForWriting,True).Write SQL
' Shell "Notepad.exe C:\Temp\SQL.txt", vbNormalFocus
'Resume
End Function


Private Property Get connText() As ADODB.Connection
On Error GoTo ErrSub

Dim strTempFolder

If m_objConnText Is Nothing Then

Set m_objConnText = New ADODB.Connection
strTempFolder = TempSQLFolder ' this will test whether the folder permits SQL READ operations
Application.DisplayAlerts = False
' MS-Access ACE OLEDB Provider
m_strConnText = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & strTempFolder & Chr(34) & ";Persist Security Info=True;"
m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;CharacterSet=UNICODE;HDR=Yes;HDR=Yes;IMEX=1;MaxScanRows=1" & Chr(34) & ";"

End If

If Not m_objConnText Is Nothing Then

With m_objConnText
If .State = adStateClosed Then
Application.StatusBar = "Connecting to the local Excel tables"
.CursorLocation = adUseClient
.CommandTimeout = 90
.ConnectionString = m_strConnText
.Mode = adModeRead
.Open
End If
End With

If m_objConnText.State = adStateClosed Then
Set m_objConnText = Nothing
End If

End If

Set connText = m_objConnText

ExitSub:
Application.StatusBar = False
Exit Property
ErrSub:
MsgBox "Error connecting to the Excel local data. Please contact " & SUPPORT & ".", vbCritical + vbApplicationModal, "Database connection failure!", 10
Resume ErrEnd
' Resume ExitSub
ErrEnd:
End ' Terminal error. Halt.

End Property


Public Sub CloseConnections()
On Error Resume Next

Set m_objConnText = Nothing

End Sub

Public Function TempSQLFolder() As String
Application.Volatile False

' Location of temporary table files used by the SQL text data functions
' Also runs a background process to clear out files over 7 days old
' The best location is a named subfolder in the user's temp folder. The
' user local 'temp' folder is discoverable on all Windows systems using
' GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath
' and will usually be C:\Users\[User Name]\AppData\Local\Temp
' Dependencies:
' Object Property FSO (Returns Scripting.FilesystemObject)
'
Dim strCMD As String
Dim strMsg As String
Dim strNamedFolder As String
Static strTempFolder As String ' Cache it
Dim iRetry As Integer
Dim i As Long

' If we've already found a usable temp folder, use the static value
' without querying the file system and testing write privileges again:

If strTempFolder <> "" Then
TempSQLFolder = strTempFolder
Exit Function
End If

On Error Resume Next

strTempFolder = GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath

If Right(strTempFolder, 1) <> "\" Then
strTempFolder = strTempFolder & "\"
End If

strTempFolder = strTempFolder & "XLSQL"

If Not FSO.FolderExists(strTempFolder) Then
FSO.CreateFolder strTempFolder
End If

i = 1
Do Until FSO.FolderExists(strTempFolder) Or i > 6
Sleep i * 250
Application.StatusBar = "Waiting for SQL cache folder" & String(i Mod 4, ".")
Loop

If Not FSO.FolderExists(strTempFolder) Then
GoTo Retry
End If

If Right(strTempFolder, 1) <> "\" Then
strTempFolder = strTempFolder & "\"
End If

TempSQLFolder = strTempFolder
Application.StatusBar = False

End Function


Public Property Get FSO() As Scripting.FileSystemObject '
' Return a File System Object
On Error Resume Next

If m_objFSO Is Nothing Then
Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If

If m_objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
End If

Set FSO = m_objFSO

End Property


Public Sub SaveTable(Optional TableName As String = "*")
' Export a Table object to the local SQL Folder as a csv file
' If no name is specified, all tables are exported asynchronously
' This step is essential for running SQL on the tables

Dim wks As Excel.Worksheet
Dim oList As Excel.ListObject
Dim sFile As String
Dim bAsync As Boolean

If TableName = "*" Then
bAsync = True
Else
bAsync = False
End If

For Each wks In ThisWorkbook.Worksheets
For Each oList In wks.ListObjects
If oList.Name Like TableName Then
sFile = oList.Name
ArrayToCSV oList.Range.Value2, sFile, , , , , , , , bAsync
'Debug.Print "[" & sFile & ".csv] "
End If
Next oList
Next wks

SetSchema

End Sub

Public Sub RemoveTable(Optional TableName As String = "*")
On Error Resume Next

' Clear up the temporary 'Table' files in the user local temp folder:

Dim wks As Excel.Worksheet
Dim oList As Excel.ListObject
Dim sFile As String
Dim sFolder As String

sFolder = TempSQLFolder

For Each wks In ThisWorkbook.Worksheets

For Each oList In wks.ListObjects
If oList.Name Like TableName Then
sFile = oList.Name & ".csv"
If Len(Dir(sFile)) > 0 Then
Shell "CMD /c DEL " & Chr(34) & sFolder & sFile & Chr(34), vbHide ' asynchronous deletion
End If
End If
Next oList

Next wks

End Sub
分享和享受:这都是一个可怕的 hack,但它为您提供了一个稳定的 SQL 平台。
而且我们仍然没有一个稳定的“ native ”平台用于 Excel 上的 SQL:Microsoft.ACE.OLEDB.14.0 Excel 数据提供程序仍然存在与 Microsoft.Jet.OLEDB.4.0 和之前的 Excel ODBC 驱动程序相同的内存泄漏它,二十年前。

关于sql - excel vba - 在电子表格上查询,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/7285857/

28 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com