vba,excel,wps,sql保存服务器

vba，excel ，wps,sql保存服务器2019-09-02

参考地址12:02:11   特别注意 双引号下的变量 看看转义的手法    SQL = " Select * from [" & wsName & "]"

 http://club.excelhome.net/thread-859194-1-1.html

Option Private Module
'Public Const ID As String = "WIN-OM179101SM0sqlexpress"  '数据库服务器名称
Public Const ID As String = "WIN-OM179101SM0"
Public Const DataBase As String = "demo"          '数据库名称
Public Const UserName As String = "sa"            '数据库连接用户名
Public Const PassWord As String = "11111111"  '数据库连接密码


Sub ExcelToServer()
    Dim cn As New ADODB.Connection, i%, j%, strTable$, n
    Dim rs As New ADODB.Recordset
    Dim cnStr As String, SQL As String, wsName$
    wsName = ActiveSheet.Name
    'Cells(1, 5).Value = wsName
    On Error GoTo errHandle
    cnStr = "Provider=sqloledb;Server=" & ID & ";Database=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & ";"
    cn.ConnectionTimeout = 10
    cn.Open cnStr
    SQL = "if exists(select * from sysobjects where name='" & wsName & "') drop table " & wsName
    i = Cells(1, 16384).End(xlToLeft).Column
    strTable = " create table " & wsName & "("
    For j = 1 To i
        If Cells(1, j).Value = "" Then
            MsgBox "检测到标题行存在空值，导入失败！", vbInformation, "提醒"
            Exit Sub
        Else
            If j = 1 Then
                strTable = strTable & Cells(1, j).Value & " varchar(100) null"
            Else
                strTable = strTable & "," & Cells(1, j).Value & " varchar(100) null"
            End If
        End If
    Next
    SQL = SQL & strTable & ")"
    
    Set rs = cn.Execute(SQL)  '删除数据库同名数据表
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    
    
    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    cn.Open cnStr
    SQL = "insert into [odbc;Driver={SQL Server};Server=" & ID & ";DataBase=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & "].[" & wsName & "] Select * from [" & wsName & "$]"
    Set rs = cn.Execute(SQL, n)
    If n > 0 Then
        MsgBox "成功上传" & n & "条数据到数据库!", vbInformation, "提醒"
    Else
        MsgBox "没导入数据！"
    End If
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    Exit Sub
errHandle:
    MsgBox "数据库连接失败或者发生不可预料的错误！错误号:" & Err.Number & ",错误信息:" & Err.Description, vbInformation, "提醒您"
End Sub

　　

表格名 就是 数据库表名

.

 查询  普通版

Sub ExcelToServer()
    Dim ID As String
    ID = "WIN-OM179101SM0" '数据库名称'Public Const ID As String = "WIN-OM179101SM0sqlexpress"  '数据库服务器名称
       Dim DataBase As String
    DataBase = "demo" '数据库名
       Dim UserName As String
    UserName = "sa" '数据库连接用户名
       Dim PassWord As String
    PassWord = "11111111" '数据库连接密码
    
    
    Dim cn As New ADODB.Connection, i%, j%, strTable$, n
    Dim rs As New ADODB.Recordset
    Dim cnStr As String, SQL As String, wsName$
    wsName = ActiveSheet.Name
    'Cells(1, 5).Value = wsName
    On Error GoTo errHandle
    cnStr = "Provider=sqloledb;Server=" & ID & ";Database=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & ";"
    cn.ConnectionTimeout = 10
    cn.Open cnStr
    SQL = "if exists(select * from sysobjects where name='" & wsName & "') drop table " & wsName
    i = Cells(1, 16384).End(xlToLeft).Column
    strTable = " create table " & wsName & "("
    For j = 1 To i
        If Cells(1, j).Value = "" Then
            MsgBox "检测到标题行存在空值，导入失败！", vbInformation, "提醒"
            Exit Sub
        Else
            If j = 1 Then
                strTable = strTable & Cells(1, j).Value & " varchar(100) null"
            Else
                strTable = strTable & "," & Cells(1, j).Value & " varchar(100) null"
            End If
        End If
    Next
    SQL = SQL & strTable & ")"
    
    Set rs = cn.Execute(SQL)  '删除数据库同名数据表
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    
    
    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    cn.Open cnStr
    SQL = "insert into [odbc;Driver={SQL Server};Server=" & ID & ";DataBase=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & "].[" & wsName & "] Select * from [" & wsName & "$]"
    Set rs = cn.Execute(SQL, n)
    If n > 0 Then
        MsgBox "成功上传" & n & "条数据到数据库!", vbInformation, "提醒"
    Else
        MsgBox "没导入数据！"
    End If
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    Exit Sub
errHandle:
    MsgBox "数据库连接失败或者发生不可预料的错误！错误号:" & Err.Number & ",错误信息:" & Err.Description, vbInformation, "提醒您"
End Sub

Sub 查询sql()
   ID = "WIN-OM179101SM0" '数据库名称'Public Const ID As String = "WIN-OM179101SM0sqlexpress"  '数据库服务器名称
       Dim DataBase As String
    DataBase = "demo" '数据库名
       Dim UserName As String
    UserName = "sa" '数据库连接用户名
       Dim PassWord As String
    PassWord = "11111111" '数据库连接密码


'On Error Resume Next       '如果出现错误，忽略，然后执行下一行代码。
Application.ScreenUpdating = False '关闭屏幕刷新,成对出现，提高速度
Application.DisplayAlerts = False '关闭提示，,成对出现，避免出现提示框
    wsName = "excxl_sql_1"
    Dim cn As New ADODB.Connection, i%, j%
    Dim rs As New ADODB.Recordset
    Dim cnStr As String, SQL As String
    

      cnStr = "Provider=sqloledb;Server=" & ID & ";Database=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & ";"
    cn.ConnectionTimeout = 10
    cn.Open cnStr
    
    SQL = " Select * from [" & wsName & "]"
    
    Set rs = cn.Execute(SQL)

   Sheets("查询结果").Cells.ClearContents '清理保存数据的区域
   Sheets("查询结果").Range("a2").CopyFromRecordset rs '粘贴表格
  
Application.ScreenUpdating = True '关闭屏幕刷新,成对出现，提高速度
Application.DisplayAlerts = True '关闭提示，,成对出现，避免出现提示框
    If rs.State = adStateOpen Then rs.Close ' 关闭结果缓存
    If cn.State = adStateOpen Then cn.Close '关闭数据库
    Exit Sub
End Sub

　　

查询 高级版  用公共函数  改密码 只需改一次  应用的时候 宏列表是没有显示的  需要    文件名！宏函数名

Option Private Module
'Public Const ID As String = "WIN-OM179101SM0sqlexpress"  '数据库服务器名称
Public Const ID As String = "WIN-OM179101SM0"
Public Const DataBase As String = "demo"          '数据库名称
Public Const UserName As String = "sa"            '数据库连接用户名
Public Const PassWord As String = "11111111"  '数据库连接密码


Sub ExcelToServer()
    Dim cn As New ADODB.Connection, i%, j%, strTable$, n
    Dim rs As New ADODB.Recordset
    Dim cnStr As String, SQL As String, wsName$
    wsName = ActiveSheet.Name
    'Cells(1, 5).Value = wsName
    On Error GoTo errHandle
    cnStr = "Provider=sqloledb;Server=" & ID & ";Database=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & ";"
    cn.ConnectionTimeout = 10
    cn.Open cnStr
    SQL = "if exists(select * from sysobjects where name='" & wsName & "') drop table " & wsName
    i = Cells(1, 16384).End(xlToLeft).Column
    strTable = " create table " & wsName & "("
    For j = 1 To i
        If Cells(1, j).Value = "" Then
            MsgBox "检测到标题行存在空值，导入失败！", vbInformation, "提醒"
            Exit Sub
        Else
            If j = 1 Then
                strTable = strTable & Cells(1, j).Value & " varchar(100) null"
            Else
                strTable = strTable & "," & Cells(1, j).Value & " varchar(100) null"
            End If
        End If
    Next
    SQL = SQL & strTable & ")"
    
    Set rs = cn.Execute(SQL)  '删除数据库同名数据表
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    
    
    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    cn.Open cnStr
    SQL = "insert into [odbc;Driver={SQL Server};Server=" & ID & ";DataBase=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & "].[" & wsName & "] Select * from [" & wsName & "$]"
    Set rs = cn.Execute(SQL, n)
    If n > 0 Then
        MsgBox "成功上传" & n & "条数据到数据库!", vbInformation, "提醒"
    Else
        MsgBox "没导入数据！"
    End If
    If rs.State = adStateOpen Then rs.Close
    If cn.State = adStateOpen Then cn.Close
    Exit Sub
errHandle:
    MsgBox "数据库连接失败或者发生不可预料的错误！错误号:" & Err.Number & ",错误信息:" & Err.Description, vbInformation, "提醒您"
End Sub

Sub 查询sql()
'On Error Resume Next       '如果出现错误，忽略，然后执行下一行代码。
Application.ScreenUpdating = False '关闭屏幕刷新,成对出现，提高速度
Application.DisplayAlerts = False '关闭提示，,成对出现，避免出现提示框
    wsName = "excxl_sql_1"
    Dim cn As New ADODB.Connection, i%, j%
    Dim rs As New ADODB.Recordset
    Dim cnStr As String, SQL As String
    

      cnStr = "Provider=sqloledb;Server=" & ID & ";Database=" & DataBase & ";Uid=" & UserName & ";Pwd=" & PassWord & ";"
    cn.ConnectionTimeout = 10
    cn.Open cnStr
    
    SQL = " Select * from [" & wsName & "]"
    
    Set rs = cn.Execute(SQL)

   Sheets("查询结果").Cells.ClearContents '清理保存数据的区域
   Sheets("查询结果").Range("a2").CopyFromRecordset rs '粘贴表格
  
Application.ScreenUpdating = True '关闭屏幕刷新,成对出现，提高速度
Application.DisplayAlerts = True '关闭提示，,成对出现，避免出现提示框
    If rs.State = adStateOpen Then rs.Close ' 关闭结果缓存
    If cn.State = adStateOpen Then cn.Close '关闭数据库
    Exit Sub
End Sub