office2003 基本完成了vba的工作,设置后自动连接数据库,自动读取,点击保存后自动保存,该新增的新增,改修改修改,自动出表 sheet1 Private Sub CommandButton1_Click() GetData End Sub Private Sub CommandButton2_Click() Me.Clear_y 1, 2, 11, SheetName_Z End Sub Private Sub CommandButton4_Click() 'MsgBox Chr(66) UserForm2.Show End Sub Sub GetData() '初始化 My_inite Dim conn As adodb.Connection Dim Ds As adodb.Recordset Dim col As Integer Set conn = New adodb.Connection Set Ds = New adodb.Recordset '打开数据库连接 conn.Open strConn With Ds '根据查询语句获得数据 .Open strSql_g, conn '自动控制加入所有列标题 For col = 0 To Ds.Fields.Count - 1 '请注意Offset(0, col)中的参数一定要正确噢 Range("A1").Offset(0, col).Value = Ds.Fields(col).Name Next '加入所有行数据 Range("a1").Offset(1, 0).CopyFromRecordset Ds End With '以下是关闭数据库连接和清空资源 Set Ds = Nothing conn.Close Set conn = Nothing End Sub Private Sub CommandButton3_Click() '初始化 My_inite Dim Ds As adodb.Recordset Dim conn As adodb.Connection Set conn = New adodb.Connection Set Ds = Me.GetDate_y(strSql, strConn, conn) Dim mycount As adodb.Recordset Set mycount = Me.GetDate_y(strSql_2, strConn, conn) Dim temp_sh Set temp_sh = ActiveWorkbook.Sheets(SheetName_Z) ' MsgBox temp_sh.Cells(2, 2). Dim SqlZ As String '用来存储整个的sql Dim sqlz1 As String '用来存储单个的update sql 语句 Dim ydh_i As Integer For ydh_i = 1 To 1 + mycount(0).Value - 1 'ActiveSheet.UsedRange.Rows.Count sqlz1 = "" '单个sql语句初始化 Dim ydh_j As Integer For ydh_j = 1 To Zong_hang 'MsgBox VarType(temp_sh.Cells(ydh_i + 1, ydh_j).Value) If Not IsVType(VarType(temp_sh.Cells(ydh_i + 1, ydh_j).Value), myType_y(ydh_j - 1)) Then MsgBox "您输入的类型不匹配" temp_sh.Cells(ydh_i + 1, ydh_j).Value = "不匹配" Exit Sub End If If temp_sh.Cells(ydh_i + 1, ydh_j).Value = Ds(ydh_j - 1).Value Then 'MsgBox "yes" '+ temp_sh.Cells(ydh_i + 1, ydh_j).Value + " " + Ds(ydh_j - 1).Value Else 'MsgBox "no" '+ temp_sh.Cells(ydh_i + 1, ydh_j).Value + " " + Ds(ydh_j - 1).Value sqlz1 = CreatUpdate(sqlz1, cols(ydh_j - 1), temp_sh.Cells(ydh_i + 1, ydh_j).Value, False) End If Next ydh_j ' 单条的sql语句加结尾 If sqlz1 <> "" Then sqlz1 = CreatUpdate(sqlz1, "ID", Ds("ID").Value, True) End If Ds.MoveNext SqlZ = SqlZ + sqlz1 Next ydh_i Dim ydh_ii As Integer For ydh_ii = 1 + 1 + mycount(0).Value - 1 To ActiveSheet.UsedRange.Rows.Count - 1 '自己摸索貌似ActiveSheet.UsedRange.Rows.Count - 1是最后一行 Dim n_i As Integer Dim colz(10) As String For n_i = 1 To Zong_hang If Not IsVType(VarType(temp_sh.Cells(ydh_ii + 1, n_i).Value), myType_y(n_i - 1)) Then MsgBox "您输入的类型不匹配" temp_sh.Cells(ydh_i + 1, n_i).Value = "不匹配" Exit Sub End If colz(n_i - 1) = temp_sh.Cells(ydh_ii + 1, n_i).Value Next n_i Dim sqlz2 As String sqlz2 = CreatInsert(colz) SqlZ = SqlZ + sqlz2 Next ydh_ii '释放,弱啊,比。net弱太多了 conn.Close Set conn = Nothing MsgBox SqlZ If SqlZ = "" Then Else Me.Excute_y SqlZ, strConn End If End Sub '判断输入类型 Function IsVType(myinput As Integer, vType As Integer) As Boolean Select Case vType Case 0 IsVType = True Case 1 If myinput = 2 Or myinput = 3 Or myinput = 4 Or myinput = 5 Or myinput = 14 Then IsVType = True Else IsVType = False End If Case 2 If myinput = 7 Then IsVType = True Else IsVType = False End If Case Else IsVType = False End Select End Function '清除excel某块得方法 Sub Clear_y(BeginX As Integer, BeginY As Integer, width As Integer, SheetName As String) Dim temp_sh Set temp_sh = ActiveWorkbook.Sheets(SheetName) Dim ydh_i As Integer For ydh_i = BeginY To ActiveSheet.UsedRange.Rows.Count Dim ydh_j As Integer For ydh_j = BeginX To BeginX + width - 1 temp_sh.Cells(ydh_i, ydh_j).Value = "" Next ydh_j Next ydh_i End Sub '取得数据的方法 Function GetDate_y(strSql As String, strCon As String, conn As adodb.Connection) As adodb.Recordset Dim Ds As adodb.Recordset Set Ds = New adodb.Recordset '打开数据库连接 还不能重复打开,真tm弱 (#‵′)靠 If conn.State = 0 Then conn.Open strCon End If '根据查询语句获得数据 Ds.Open strSql, conn 'conn.Close 'Set conn = Nothing Set GetDate_y = Ds End Function '执行数据的方法 Sub Excute_y(strSql As String, strCon As String) Dim conn As adodb.Connection Dim Ds As adodb.Command Set conn = New adodb.Connection Set Ds = New adodb.Command conn.Open strCon Ds.CommandText = strSql Ds.ActiveConnection = conn Ds.Execute '以下是关闭数据库连接和清空资源 Set Ds = Nothing conn.Close Set conn = Nothing End Sub '拼接update的方法 Function CreatUpdate(strSql As String, colName As String, strValue As String, IsEnd As Boolean) If strSql = "" Then strSql = "update " + TableName + " set " End If If IsEnd Then strSql = Left(strSql, Len(strSql) - 1) strSql = strSql + " where " + colName + "='" + strValue + "';" Else strSql = strSql + colName + "='" + strValue + "'," End If CreatUpdate = strSql End Function '拼接insert语句的方法 Function CreatInsert(strValues() As String) As String Dim sql As String sql = "insert into " + TableName + " (" '日期,班次,机种,班前在工,当日领取,当日生产,理论在工,班后实际在工,差异,作业者,备注) values(" Dim y_i As Integer For y_i = 0 To Zong_hang - 2 sql = sql + cols(y_i) + "," Next y_i sql = sql + cols(Zong_hang - 1) + ") values(" Dim i As Integer For i = 0 To Zong_hang - 2 sql = sql + "'" + strValues(i) + "'," Next i sql = sql + "'" + strValues(Zong_hang - 1) + "');" CreatInsert = sql End Function 关于自动出表的form2 Dim myText(Zong_hang - 1) As MSForms.CheckBox Private Sub UserForm_Activate() '动态加载控件 Dim hang As Integer For hang = 1 To Zong_hang Set myText(hang - 1) = Controls.Add("Forms.CheckBox.1", "ydh" + str(hang), Visible) With myText(hang - 1) .Visible = True .Caption = Sheet1.Cells(1, hang).Value .Left = 100 .Top = 20 * (hang - 1) .Value = True End With Next hang End Sub '对可选区域做的处理 Function myRange_C() As Range Dim mr As Range Dim R As Integer R = ActiveSheet.UsedRange.Rows.Count With Sheet1 Dim y_i As Integer For y_i = 1 To Zong_hang If myText(y_i - 1).Value Then Set mr = MyRange_De(mr, Chr(64 + y_i) & 1 & ":" & Chr(64 + y_i) & R) End If Next y_i End With Set myRange_C = mr End Function '自己写的添加区域的方法 Function MyRange_De(myrange As Range, myarea As String) As Range If myrange Is Nothing Then Set myrange = Range(myarea) Else Set myrange = Union(myrange, Range(myarea)) End If Set MyRange_De = myrange End Function Private Sub CommandButton1_Click() Dim myrange As Range Dim myChart As ChartObject Dim R As Integer With Sheet1 .ChartObjects.Delete 'R = .Range("A65536").End(xlUp).Row R = ActiveSheet.UsedRange.Rows.Count '不知道为什么这里的测试和我以前的不一样,不用-1 '这里解决了可选问题。 'Set myRange = Union(.Range("E" & 1 & ":E" & R), .Range("G" & 1 & ":G" & R)) Set myrange = myRange_C Set myChart = .ChartObjects.Add(100, 50, 700, 450) With myChart.Chart .ChartType = xlColumnClustered .SetSourceData Source:=myrange, PlotBy:=xlColumns .ApplyDataLabels ShowValue:=True .HasTitle = True .ChartTitle.Text = TableName With .ChartTitle.Font .Size = 20 .ColorIndex = 3 .Name = "华文新魏" End With With .ChartArea.Interior .ColorIndex = 8 .PatternColorIndex = 1 .Pattern = xlSolid End With With .PlotArea.Interior .ColorIndex = 35 .PatternColorIndex = 1 .Pattern = xlSolid End With '.SeriesCollection(1).XValues = "=Sheet1!R2C1:R7C1" '.SeriesCollection(1).DataLabels.Delete 'With .SeriesCollection(1).DataLabels.Font ' .Size = 10 ' .ColorIndex = 5 'End With End With End With Set myrange = Nothing Set myChart = Nothing Unload Me End Sub 关于全局变量的设置 '记录总的链接字符串 Public Const strConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=**;Password=***;Initial Catalog=Protal;Data Source=****" 'Sheet1 的名称 Public Const SheetName_Z = "Sheet1" '记录表的总行数 注意 主键必须叫ID 注意,这个行数不包括ID 注意这个行数是从1开始数的 Public Const Zong_hang = 11 '记录表名称 注意 主键必须叫ID Public Const TableName = "**" '记录每列的列名称 Public cols(Zong_hang - 1) As String '自己定义的类型方法 记录每列的类型 0 string, 1 int, 2 date 需要根据实际表调整 Public myType_y(Zong_hang - 1) As Integer '公共查询语句 已经在初始化函数中自动拼接 不用管 Public strSql_g As String Public strSql As String Public strSql_2 As String '初始化函数 需要改的是对列名得赋值和列类型的赋值 Sub My_inite() '首先赋初始值 cols(0) = "**" 'vba 不能在声明变量的时候赋值,弱弱弱 (#‵′) cols(1) = "**" cols(2) = "**" cols(3) = "**" cols(4) = "**" cols(5) = "**" cols(6) = "**" cols(7) = "**" cols(8) = "**" cols(9) = "**" cols(10) = "**" '自己定义的类型方法 0 string, 1 int, 2 date 需要根据实际表调整 这里跟提示相关 myType_y(0) = 2 myType_y(1) = 0 myType_y(2) = 0 myType_y(3) = 0 myType_y(4) = 1 myType_y(5) = 1 myType_y(6) = 1 myType_y(7) = 1 myType_y(8) = 0 myType_y(9) = 0 myType_y(10) = 0 '以下不用改 strSql_g = "select " strSql = "select " Dim y_i As Integer For y_i = 0 To Zong_hang - 2 strSql_g = strSql_g + cols(y_i) + "," strSql = strSql + cols(y_i) + "," Next y_i strSql_g = strSql_g + cols(Zong_hang - 1) + " from " + TableName strSql = strSql + cols(Zong_hang - 1) + ",ID from " + TableName strSql_2 = "select count(*) from " + TableName End Sub