Sub 原始()
Set con = CreateObject("ADODB.Connection")
Set Recordset = CreateObject("ADODB.Recordset")
Set ws = ThisWorkbook.Worksheets("要查找结果")
path = ThisWorkbook.FullName
'path = "C:\Users\your\Documents\Database1.accdb;"
With con
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0';Data Source=" & path
.Open
End With
Dim SQL As String
SQL = "SELECT * FROM [表1$] " '如想从第二行开始[表名$A2:Z65536]
'con.Execute ("DELETE FROM [表1$] WHERE 序号 = ('aaa')")
Recordset.Open SQL, con
For i = 1 To Recordset.Fields.Count
ws.Cells(1, i) = Recordset.Fields(i - 1).Name
Next
ws.Range("A2").CopyFromRecordset Recordset
Recordset.Close
con.Close
Set Recordset = Nothing
Set con = Nothing
Set ws = Nothing
End Sub
改进版本
MySQL_Excel.cls
Public mySQLstr As String
Private connection_ As Driver
Private con As Object
Private cmd As Object
Private rs As Object
Private FileSys As Object
Private dict As Object
Private mysqle As String
Private SQL As String
Private string处理 As 字符处理
Public Enum Driver
mySQL = 1
wps = 2
excel2016 = 3
End Enum
'是低版本的excel、wps使用Excel_8
Const Excel_8 = "Extended Properties='Excel 8.0';"
Const Excel_12 = "Extended Properties='Excel 12.0';"
'是低版本的excel、wps使用Excel_12
Const ApplicationVersion_12 = "Provider=Microsoft.Jet.Oledb.4.0;Data source="
Const ApplicationVersion_16 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
Public Function mysql_ConnectionString(ByVal server As String, ByVal database As String, ByVal uid As String, ByVal pwd As String)
mysqle = "Driver={MySQL ODBC 8.0 Unicode Driver}" _
& ";server = " & server _
& ";Port=3306" _
& ";DB=" & database _
& ";UID=" & uid _
& ";PWD=" & pwd _
'& ";OPTION=3;"
End Function
'
Public Property Let PenConnectionString(Optional ByVal Connection As Driver, ByVal path As String)
Dim ExtensionName
Select Case Connection
Case mySQL
con.ConnectionString = mysqle
Case excel2016
con.ConnectionString = ApplicationVersion_16 & path
Case Else
con.ConnectionString = ApplicationVersion_12 & path
End Select
'
ExtensionName = string处理.GetFileExtensionSafe(path)
If string处理.StringContainsAny(ExtensionName, "xls", "xlsx", "xlsb", "xlsm") Then
Select Case Application.Version
Case "16.0"
con.ConnectionString = con.ConnectionString & ";" & Excel_12
Case "12.0"
con.ConnectionString = con.ConnectionString & ";" & Excel_8
End Select
connection_ = Connection
End If
End Property
'根据连接con.ConnectionString是否是excel文件,使表名符合sql语句
'示例:[表$]
Private Function SQL_Table(ByVal YourTable As String)
Select Case connection_
Case wps, excel2016
YourTable = "[" & YourTable & "$]"
End Select
SQL_Table = YourTable
End Function
Public Property Let SetSQL(ByVal strsql As String)
SQL = strsql
End Property
Public Property Get GetSQL() As String
GetSQL = SQL
End Property
Public Property Get SQL_Insert_增(ByVal YourTable As String, ByVal YourColumns As Variant, ByVal YourValues As Variant) As MySQL_Excel
YourTable = SQL_Table(YourTable)
coloumns = string处理.ColsVals(YourColumns)
vals = string处理.ColsVals(YourValues, 是)
SQL = "INSERT INTO " & YourTable & "(" & coloumns & ")" & " values " & "(" & vals & ")"
Set SQL_Insert_增 = Me
End Property
Public Property Get SQL_Select_查(ByVal YourTable As String, Optional YourColumns As Variant) As MySQL_Excel
YourTable = SQL_Table(YourTable)
If VarType(YourColumns) = vbError Then
YourColumns = "*" '判断YourColumns是否传参,如果没有,则赋值 "*"
Else
YourColumns = string处理.ColsVals(YourColumns)
End If
SQL = "SELECT " & YourColumns & " FROM " & YourTable
Set SQL_Select_查 = Me
End Property
Public Property Get SQL_Update_改(ByVal YourTable As String, ByVal Columns_Or_Dict As Variant) As MySQL_Excel
YourTable = SQL_Table(YourTable)
Dim KeyValues
If TypeName(Columns_Or_Dict) = "Dictionary" Then KeyValues = string处理.ColsVals(Columns_Or_Dict)
SQL = "UPDATE " & YourTable & " SET " & KeyValues
Set SQL_Update_改 = Me
End Property
Public Property Get SQL_Delete_删(ByVal YourTable As String) As MySQL_Excel
YourTable = SQL_Table(YourTable)
SQL = "DELETE FROM " & YourTable
Set SQL_Delete_删 = Me
End Property
Public Property Get Where(ByVal Col As Variant, ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As MySQL_Excel
Dim condition
SQL = SQL & " WHERE " & string处理.SQL_condition(Col, vals, condition_)
Set Where = Me
End Property
Public Property Get And_(ByVal Col As Variant, Optional ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As MySQL_Excel
Dim condition
SQL = SQL & " AND " & string处理.SQL_condition(Col, vals, condition_)
Set And_ = Me
End Property
Public Sub SQL_Execute(Optional ByVal strsql As String)
If strsql <> "" Then SQL = strsql
If con.State = 0 Then con.Open
With cmd
.ActiveConnection = con
.CommandText = SQL
.Execute
End With
End Sub
Public Function Recordset(sht) As Object '传入工作表名称,并将该工作表以Recordset结果集返回
If con.State <> 0 Then con.Close
If con.State = 0 Then con.Open
rs.Open SQL, con
Set Recordset = rs
End Function
Public Sub rs_sht(Optional sheet As Variant) '参数sheet是工作表的名称,如果没有就新建该工作表
Set rs = Recordset(sheet)
If Sheet_exists(sheet) = False Then Worksheets.Add().Name = sheet '判断是否存在名字"MySQL_Excel"的工作表存在,如果不存在就新建
Set ws = Worksheets(sheet)
ws.Cells.ClearContents
Dim i As Integer
For i = 1 To rs.Fields.Count
ws.Cells(2, i) = rs.Fields(i - 1).Name
Next
ws.Range("A1").CopyFromRecordset rs
End Sub
'判断工作表是否存在,返回True或者False
Private Function Sheet_exists(Optional sheet As Variant) As Boolean
On Error Resume Next
If sheet = "" Then sheet = "查询结果"
Set ws = ActiveWorkbook.Sheets(sheet)
If ws Is Nothing Then
Sheet_exists = False '工作表不存在返回false
Else
Sheet_exists = True '存在返回true
End If
Set ws = Nothing
End Function
'初始化加载
Private Sub Class_Initialize()
Set string处理 = New 字符处理
Set rs = CreateObject("adodb.recordset")
Set con = CreateObject("ADODB.Connection")
Set cmd = CreateObject("ADODB.Command")
Set dict = CreateObject("Scripting.Dictionary")
End Sub
'程序结束时关闭
Private Sub Class_Terminate()
On Error Resume Next
con.Close: Set con = Nothing
rs.Close: Set rs = Nothing
Set cmd = Nothing
Set dict = Nothing
Err.Clear
End Sub
字符处理.cls
Public Enum 是否
否 = 1
是 = 2
End Enum
Public Enum 条件
等于 = 0
大于 = 1
小于 = 2
包含 = 3
不包含 = 4
包含字符 = 5
不包含字符 = 6
End Enum
Public Enum 字符匹配
左 = 1
中 = 2
右 = 3
End Enum
'参数:vals如果是
'【String:字符串】原样返回:( vals )
'StringsColsVals方法: 拼接返回:(str1,str2,str3……)
'DictionaryColsVals方法: key1 = 'val1' ,key2 = 'val2' ……
Public Function ColsVals(ByVal Vals_or_kv As Variant, Optional 加引号 As 是否 = 否) As String
Dim str, val
Select Case TypeName(Vals_or_kv)
Case "String":
If 加引号 = 是 Then
str = "'" & Vals_or_kv & "'"
Else
str = Vals_or_kv
End If
Case "Dictionary":
str = DictionaryColsVals(Vals_or_kv)
Case Else:
str = StringsColsVals(Vals_or_kv, 加引号)
End Select
ColsVals = str
End Function
'【String():字符数组】拼接返回:(str1,str2,str3……)
Private Function StringsColsVals(ByVal Vals_or_kv As Variant, Optional 加引号 As 是否 = 否) As String
Dim str, val
For Each val In Vals_or_kv
If 加引号 = 是 Then val = "'" & val & "'"
If str <> "" Then
str = str & "," & val
Else
str = val
End If
Next val
StringsColsVals = str
End Function
'【Dictionary:字典】拼接返回: key1 = 'val1' ,key2 = 'val2' ……
Private Function DictionaryColsVals(ByVal Vals_or_kv As Variant) As String
Dim str
For Each key In Vals_or_kv.Keys
If str <> "" Then
str = str & "," & key & "='" & Vals_or_kv(key) & "'"
Else
str = key & "='" & Vals_or_kv(key) & "'"
End If
Next key
DictionaryColsVals = str
End Function
Public Function SQL_LikeValue(ByVal val As String, Optional ByVal like_ As 字符匹配 = 字符匹配.中) As String
Select Case like_
Case 字符匹配.左
SQL_LikeValue = "'" & val & "%'"
Case 字符匹配.中
SQL_LikeValue = "'%" & val & "%'"
Case 字符匹配.右
SQL_LikeValue = "'%" & val & "'"
End Select
End Function
'第一个Case条件:示例 传入【col,str,大于】 返回:col > 'str'
'第二个Case条件:示例 传入【col,Array("str1","str2"),包含】 返回:col IN ('str1','str2')
'第三个Case条件:示例 传入【col,str,包含字符】 返回:col like *str*
Public Function SQL_condition(ByVal Col As Variant, Optional ByVal vals As Variant, Optional condition_ As 条件 = 条件.等于) As String
Dim condition
Select Case condition_
Case 条件.大于, 条件.等于, 条件.小于:
vals = ColsVals(vals, 是)
If condition_ = 条件.大于 Then condition = " > "
If condition_ = 条件.等于 Then condition = " = "
If condition_ = 条件.小于 Then condition = " < "
Case 条件.包含, 条件.不包含:
vals = "(" & ColsVals(vals, 是) & ")"
If condition_ = 条件.包含 Then condition = " IN "
If condition_ = 条件.不包含 Then condition = " NOT IN "
Case 条件.包含字符, 条件.不包含字符
vals = SQL_LikeValue(vals)
If condition_ = 条件.包含字符 Then condition = " LIKE "
If condition_ = 条件.不包含字符 Then condition = " NOT LIKE "
End Select
SQL_condition = Col & condition & vals
End Function
'返回文件路径后缀名
Public Static Function GetFileExtensionSafe(ByVal filePath As String) As String
If InStrRev(filePath, ".") > 0 Then
GetFileExtensionSafe = Mid(filePath, InStrRev(filePath, ".") + 1)
Else
GetFileExtensionSafe = "" ' 如果没有扩展名,则返回空字符串
End If
End Function
'字符串中包含数组中任意一个返回TRUE
Function StringContainsAny(ByVal str As String, ParamArray arr() As Variant) As Boolean
Dim i As Long
For i = LBound(arr) To UBound(arr)
If InStr(1, str, arr(i), vbTextCompare) > 0 Then
StringContainsAny = True
Exit Function
End If
Next i
StringContainsAny = False
End Function
测试模块
Sub 测试增加数据sql()
Dim ms As New MySQL_Excel
'path = "C:\Users\Your\Documents\Database1.accdb"
path = ThisWorkbook.FullName
ms.PenConnectionString(excel2016) = path
Dim str1, str2
str1 = Split("序号,名称,规格,本月表1", ",")
str2 = Split("111,bbbiii,123,1111", ",")
' str1 = Array("序号", "名称")
' str2 = Array("aaa", "bbb")
strsql = ms.SQL_Insert_增("表1", str1, str2).GetSQL()
Debug.Print strsql
ms.SQL_Execute
End Sub
Sub 测试查询数据sql()
Dim ms As New MySQL_Excel
'path = "C:\Users\your\Documents\Database1.accdb"
path = ThisWorkbook.FullName
ms.PenConnectionString(excel2016) = path
Cols = Split("序号,规格", ",")
vals = Split("1212001,1212005", ",")
'strsql = ms.SQL_Select_查("表1").GetSQL()
'strsql = ms.SQL_Select_查("表1", vals).GetSQL()
strsql = ms.SQL_Select_查("表1").Where("序号", vals, 包含).GetSQL()
'strsql = ms.SQL_Select_查("表1").Where("序号", "1112017").And_("规格", "浅灰色", 条件.包含).GetSQL()
Debug.Print strsql
ms.rs_sht ("要查找结果")
End Sub
Sub 测试修改数据sql()
Dim ms As New MySQL_Excel
ms.PenConnectionString(excel2016) = ThisWorkbook.FullName
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "序号", 111
dict.Add "规格", "bbb"
strsql = ms.SQL_Update_改("表1", dict).Where("序号", "1112017").GetSQL()
Debug.Print strsql
ms.SQL_Execute strsql
End Sub
'不支持删除excel文件中的数据
Sub 测试删除数据sql()
Dim ms As New MySQL_Excel
path = "C:\Users\your\Documents\Database1.accdb"
ms.PenConnectionString(excel2016) = path
strsql = ms.SQL_Delete_删("表1").Where("序号", "aaa").GetSQL()
Debug.Print strsql
ms.SQL_Execute
End Sub
表
链接:[https://pan.baidu.com/s/1GMIpUJIJET8tfyR7Ve0dcw]
提取码:6666