返回目录：excel表格制作
一个很简单的程序实例
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\msdb.mdb"
Text1.Text = Data1.DatabaseName
End Sub
'按钮，把数据e69da5e6ba90e799bee5baa6e79fa5e98193338传到Excel中
Private Sub Command1_Click()
Dim i As Integer, j As Integer
Dim newxls As Excel.Application
Dim newbook As Excel.Workbook
Dim newsheet As Excel.Worksheet
Set newxls = CreateObject("Excel.Application") '创建excel应用程序,打开excel2000
newxls.Visible = True
Set newbook = newxls.Workbooks.Add '创建工作簿
Set newsheet = newbook.Worksheets(1) '创建工作表
'If Not Data1.Recordset.EOF Then Data1.Recordset.MoveFirst
For i = 0 To Data1.Recordset.RecordCount - 1
For j = 0 To Data1.Recordset.Fields.Count - 1
DBGrid1.Row = i
DBGrid1.Col = j
newsheet.Cells(i + 1, j + 1) = DBGrid1.Text
Next j
Next i
End Sub
Dim excel As Object
Set excel = CreateObject("excel.application") '设定 excel API
'--------------这上面可不看来源 照抄
excel.workbooks.Open ("C:\book.xls") 'P.s请先自己创立 'excel 开启
excel.Visible = True 'excel 显示 or 隐藏知 (True of False
excel.cells(1,2)="测试"
text1 = excel.cells(1,2) 'text1 读取
excel.ActiveWorkbook.Save 'excel 存档
excel.quit 'excel 关闭道
Private Sub Command1_Click() Dim s1() As String, s2() As String, s3() As String, s4() As String Container = find("Container:.+\b", RichTextBox1) ContainerType = find("Container Type:\s+\S+", RichTextBox1) ContractNumber = find("Contract Number:.+\b", RichTextBox1) ContractType = find("Contract Type:.+\b", RichTextBox1) Text3 = Container & vbNewLine & ContainerType & vbNewLine & ContractNumber & vbNewLine & ContractType s1 = Split(Container, "Container: ") s2 = Split(ContainerType, "Container Type: ") s3 = Split(ContractNumber, "Contract Number: ") s4 = Split(ContractType, "Contract Type: ") '你只要将数组中元素赋值到相应表格即 Dim t As Integer Dim appexcel As Object '定义Excel应用程序对象 Dim wbmybook As Object '定义工作簿对象 Dim wsmysheet As Object '定义工作表对象 Set appexcel = CreateObject("excel.application") '创建Excel应用程序对象 Set wbmybook = appexcel.Workbooks.Add '添加工作簿 Set wsmysheet = appexcel.Worksheets.Add '添加工作表 For t = 1 To UBound(s1) wsmysheet.Cells(t, 1) = s1(t) '向EXCEL里写数据 Next For t = 1 To UBound(s2) wsmysheet.Cells(t, 2) = s2(t) '向EXCEL里写数据 Next For t = 1 To UBound(s3) wsmysheet.Cells(t, 3) = s3(t) '向EXCEL里写数据 Next For t = 1 To UBound(s1) wsmysheet.Cells(t, 4) = s4(t) '向EXCEL里写数据 Next appexcel.Visible = True '应用程序Excel可见 Set wbmybook = Nothing Set wsmysheet = Nothing Set appexcel = Nothing End Sub Function find(tiaojian As String, neirong As String) As String If tiaojian = "" Or neirong = "" Then MsgBox "输入提醒": Exit Function Dim re Set re = CreateObject("VBScript.RegExp") re.MultiLine = True re.Global = True '设置匹配时搜索str的整个字符串，若为false，只搜索str里符合条件的第一项 re.Pattern = tiaojian '定义正则表达式 re.IgnoreCase = True ' 设置是否区分字符大小写。 re.Global = True ' 设置全局可用性。 Set Matches = re.Execute(neirong) ' 执行搜索。 For Each Match In Matches ' 遍历匹配集合。 RetStr = RetStr & Match.Value & " " & vbCrLf Next find = RetStr End Function Private Sub Form_Load() RichTextBox1.FileName = "D:\我的文档\Baidu\Baidu Hi\lijinfeng042\My Files\新建 文本文档.txt" '改为你7a64e78988e69d83331的文件路径 End Sub https://gss0.baidu.com/7LsWdDW5_xN3otqbppnN2DJv/lijinfeng042/pic/item/e2c8df1059fbfae6a7ef3f2f.jpeg
这是截图 传了几次都不成功只是一个简单的例子,具体的相应增加
因为ADO不支持Excel的删除
所以用Excel+access的方法解决
新建access,在access里面添加2个表,一个"在职"表,一个"离职"表,(都将工号设置主键)
Excel按Ctrl+F11打开vbe编辑器,插入窗体
按以下步骤建立对应控件
最重要的一点就是将文本框的名称属性依次改成"工号", "姓名", "部门", "二级小组7a64e78988e69d83336", "三组小组",因为代码里要用到
建立好之后 双击窗体将以下代码复制到代码窗口中
Dim Con As Object
Dim Rst As Object
Dim Sql As String
Dim FieldArr
Const ProvidSr$ = "provider=microsoft.jet.oledb.4.0;data source="
Private Sub CommandButton1_Click()
Dim FieldSr$, ValueSr$, x%
If 工号.Text = "" Then MsgBox "工号必填": Exit Sub
For x = 0 To 4
FieldSr = FieldSr & FieldArr(x) & ", "
ValueSr = ValueSr & Me.Controls(FieldArr(x)).Text & "', '"
Next
FieldSr = Left(FieldSr, Len(FieldSr) - 2)
ValueSr = Left(ValueSr, Len(ValueSr) - 3)
Sql = "Insert into 在职 (" & FieldSr & ") VALUES('" & ValueSr & ")"
Con.Execute Sql
MsgBox "操作完成"
End Sub
Private Sub CommandButton2_Click()
Dim Wsr$, TBox$
For x = 0 To 1
TBox = Me.Controls(FieldArr(x)).Text
If TBox <> "" Then Wsr = Wsr & FieldArr(x) & "='" & TBox & "' or "
Next
If Wsr = "" Then MsgBox "请输入工号或姓名": Exit Sub
Wsr = Left(Wsr, Len(Wsr) - 4)
If MsgBox("确定删除?", vbQuestion + vbYesNo) = vbYes Then
Sql = "insert into 离职 select * from 在职 where " & Wsr
Con.Execute Sql
Sql = "delete from 在职 where " & Wsr
Con.Execute Sql
MsgBox "操作完成"
End If
End Sub
Private Sub UserForm_Initialize()
Dim AccPath$
FieldArr = Array("工号", "姓名", "部门", "二级小组", "三组小组")
Set Con = CreateObject("adodb.connection")
AccPath = "d:/Database/data.MDB" ''''这里设置数据库路径
Con.Open ProvidSr & AccPath
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Set Con = Nothing
End Sub
好了 运行就可以了
说的的excel中vba的方法 如果要做成vb软件的话,在vb中的步骤也是一样的
代码和上面一样的 只是控件名称有些不同