版权声明:本文为博主原创文章,未经博主允许不得转载。 https://blog.csdn.net/fourSeasonBeans/article/details/82903982
系统:Windows 7
软件:Excel 2010 / Access 2010
- 这个系列开展一个新的篇章,主体使用Access,包括数据库部分及界面部分,当然输出部分也会涉及到Excel,Excel的可读性还是比较好的
- 本公众号的不同阶段:Excel -> Excel + Access -> Access。但并不表示Access就一定比Excel好啊,各有所长吧,合适才是最好的
- 主体框架:换一种讲解方式,以项目为基础,从开始到结束
- 项目名称:培训管理系统
- 主要功能:两个界面。界面1,培训时录入信息;界面2,以培训老师和培训学员为客户,输出信息
- 涉及知识:Access界面,数据库知识,VBA,SQL,Excel
Part 1:本篇目标
- 输出学员的个人培训档案
- 每份档案生成一个Excel文件,命名方式:
阿大_个人学习档案_2018-09-29.xlsx
,其中日期为生成档案当天的日期 - Excel中只含有一个工作表,名称为:
个人培训档案
- 工作表中有四列:培训课程名称,培训开始时间,培训多少小时,培训老师
- 每份档案生成一个Excel文件,命名方式:
输出文件
输出Excel里的内容
操作界面
**对应数据库内的内容
03_培训记录
02_培训课程
Part 2:逻辑过程
- 检查学员姓名有无录入
- 输出该学员对应学员档案
- 从03_培训记录记录表中获取该学员对应的培训课程ID
- 以上一步骤获取的培训课程ID去02_培训课程中查询对应信息
- 输出信息至Excel表格
Part 3:代码
- 在窗体中增加一个事件
- 调用模块内的过程
窗体内代码
Private Sub 个人培训档案_Click()
Dim frmName
frmName = fFrm_pxsc_01_当前窗体名称
arr = Array("学员姓名")
check = fMod_tyk_02_是否全部填写检查(frmName, arr)
studentName = Me.Controls("学员姓名")
If check = True Then
Call sMod_sc_03_个人学习档案输出(studentName)
Else
MsgBox "请输入学员姓名"
End If
End Sub
代码截图
模块内代码
Sub sMod_sc_03_个人学习档案输出(studentName)
Rem>>
Rem>>
Dim folderAddr
Dim shijian
Dim excelFileName
Dim excelAddress
folderAddr = fMod_dz_02_输出文件地址
shijian = Format(Now(), "yyyy-mm-dd")
excelFileName = studentName & "_个人学习档案_" & shijian & ".xlsx"
excelAddress = folderAddr & "\" & excelFileName
'检查文件是否存在
If Dir(excelFileName) <> "" Then
Kill excelAddress
End If
Dim tblTrainCourse
Dim tblTrainPerson
Dim tbl2Combine
Dim searchCondition
Dim searchC1
Dim searchC2
Dim mode
Dim dbAddr
Dim SQL
Dim rsAdConn
Dim rs
Dim adConn
tblTrainCourse = "02_培训课程"
tblTrainPerson = "03_培训记录"
searchC1 = "学员姓名=" & Chr(39) & studentName & Chr(39)
SQL = "Select 培训课程ID From " & tblTrainPerson & " where(" & searchC1 & ")"
mode = 2
dbAddr = fMod_dz_01_数据库地址
rsAdConn = fMod_tyk_01_rs产生(dbAddr, SQL, mode)
Set rs = rsAdConn(0)
Set adConn = rsAdConn(1)
Dim ids
Dim pxID
ids = ""
rs.MoveFirst
For i = 0 To rs.RecordCount - 1
pxID = rs.Fields(0).Value
If ids = "" Then
ids = pxID
Else
ids = ids & "," & pxID
End If
rs.MoveNext
Next i
rs.Close
searchC2 = "培训课程ID in (" & ids & ")"
SQL = "Select 培训课程名称,培训开始时间,培训多少小时,培训老师 From " & tblTrainCourse & " where " & searchC2 _
& " order by 培训开始时间 ASC"
mode = 2
dbAddr = fMod_dz_01_数据库地址
rsAdConn = fMod_tyk_01_rs产生(dbAddr, SQL, mode)
Set rs = rsAdConn(0)
Set adConn = rsAdConn(1)
'新建Excel文件
Dim exl As New Excel.Application
Dim wb As Excel.Workbook
Dim shtTemp As Excel.Worksheet
DoCmd.SetWarnings False
exl.Workbooks.Add
exl.ActiveWorkbook.SaveAs FileName:=excelAddress, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
Set wb = exl.ActiveWorkbook
Set shtTemp = wb.Worksheets(1)
shtTemp.Name = "个人培训档案"
Dim sh
For Each sh In wb.Worksheets
If (sh.Name <> "个人培训档案") Then
sh.Delete
End If
Next
'字段名称维护到输出文件
Dim fildNum
Dim j
Dim fildName
fildNum = rs.Fields.Count
For j = 0 To fildNum - 1 Step 1
fildName = rs.Fields(j).Name
shtTemp.Cells(1, j + 1) = fildName
Next j
shtTemp.Cells(2, 1).CopyFromRecordset rs
shtTemp.Cells.EntireColumn.AutoFit
'关闭数据库连接
adConn.Close
Set adConn = Nothing
'保存工作簿
wb.Save
wb.Close
exl.Quit
MsgBox "培训信息已导出:" & Chr(13) & Chr(10) & Chr(13) & Chr(10) _
& excelAddress
End Sub
代码截图
扫描二维码关注公众号,回复:
3641971 查看本文章
Part 4:代码解读
- 本篇代码较长,重点介绍如何在Access中通过代码新建Excel文件,需新引用
Microsoft Excel 14.0 Object Library
其余代码其实和Excel-VBA中创建新的Excel文件一样,只是在最开始加上一个Excel对象
Dim exl As New Excel.Application
Dim wb As Excel.Workbook
Dim shtTemp As Excel.Worksheet
DoCmd.SetWarnings False
exl.Workbooks.Add
exl.ActiveWorkbook.SaveAs FileName:=excelAddress, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
Ps:本来打算使用left join
,之前也有用过,今晚总是报错,好吧,换个方法
祝大家:国庆快乐!
- 本文为原创作品,如需转载,可加小编微信号
learningBin
更多精彩,请关注微信公众号
扫描二维码,关注本公众号