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

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

Option Private Module
'Public Const ID As String = "WIN-OM179101SM0\sqlexpress"  '数据库服务器名称
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

　　

表格名 就是 数据库表名

.