《用Ecel建立数据录入系统》由会员分享，可在线阅读，更多相关《用Ecel建立数据录入系统（5页珍藏版）》请在金锄头文库上搜索。
1、用Excel建立数据录入系统-升级版(2013-09-06 16:02:28) 转载 标签： 分类：OFFICEexcel vba一、数据采集系统功能录入、保存、查询、清空、修改二、两个界面1. 数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”;2. 数据存储界面：后台实现数据的保存；录入界面：a -riItn flurraaEH3-mOJ1iwrlLUAjwrl沏4：1：wcdJIU口dMi.1弼三、实现方法1. 保存功能Sub Save()I保存数据Marco， xiaohou制作，时间2013-9-5Dim r1, r2, r3 As RangeWith Sheets
2、(数据存储)Set r2 = .Range(a2, .a100000.End(xlUp)End WithWith Sheets(数据录入)Set r1 = .Range(c4:e4, d6:l39)If IsEmpty(.Range(c4) Or IsEmpty(.Range(e4) ThenOr IsEmpty(.Range(b7:b41)添加科室不为空，未成功MsgBox (编码、名称为空，不可保存！)ElseSet r3 = r2.Find(.Cells(4, 3), , , 1)If Not r3 Is Nothing ThenMsgBox (此编码已存在，不可保存。如果此信息需要修改
3、，请点击查询后再修改)ElseSheets(数据存储).Rows(2:35).Insert Shift:=xlDown.Range(c6:l39).Copy 复制“数据录入”表体信息Sheets(数据存储).Range(c2:l2).PasteSpecial Paste:=xlPasteValues.Range(c4).Copy复制“数据录入”编码Sheets(数据存储).Range(a2:a35).PasteSpecial Paste:=xlPasteValues.Range(e4).Copy复制“数据录入”名称Sheets(数据存储).Range(b2:b35).PasteSpecial
4、Paste:=xlPasteValuesrl.ClearContents保存数据后，清空录入界面.Range(c4).SelectEnd IfEnd IfEnd WithEnd Sub2. 查询功能Sub Query()f查询筛选 Macro， xiaohou制作，时间2013-9-5ffDim Erow As IntegerDim r1, r2 As RangeWith Sheets(数据录入)Set r1 = .Range(d6:l39)Set r2 = .Range(a6:b39)Erow = Sheets(数据存储 ”).a100000.End(xlUp).Rowr1.ClearCon
5、tentsFor Each ce In .a2:x2If ce Then ce.Value = * & ce & *加上通配符 *，实现模糊查询NextIf IsEmpty(.Range(c4) Or IsEmpty(.Range(e4) ThenOr IsEmpty(.Range(b7:b41)添加科室不为空，未成功MsgBox (编码、名称为空，不可查询！)ElseSheets(数据存储).Range(Al:l & Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.c3:e4, CopyToRange:=.A5:l5, U
6、nique:=Falser2.Borders(xlDiagonalDown).LineStyle = xlNoner2.Borders(xlDiagonalUp).LineStyle = xlNoner2.Borders(xlEdgeLeft).LineStyle = xlNoner2.Borders(xlEdgeTop).LineStyle = xlNoner2.Borders(xlEdgeBottom).LineStyle = xlNoner2.Borders(xlEdgeRight).LineStyle = xlNoner2.Borders(xlInsideVertical).LineS
7、tyle = xlNoner2.Borders(xlInsideHorizontal).LineStyle = xlNoner2.NumberFormatLocal =;For Each ce In .a2:x2If ce Then ce.Value = Mid(ce, 2, Len(ce) - 2)取消*通配符NextEnd IfEnd WithEnd Sub3.更新Sub Update()I更新 Macro， xiaohou 制作，时间 2013-9-5Dim arr, d As ObjectDim r As RangeDim lr&, i&, j%With Sheets(数据录入)查询修
8、改工作表数据区域写入数组arrarr = .Range(A7:D & .Range(A65536).End(xlUp).Row)arr = .Range(a6:l39)Set r = .Range(d6:l39)End WithSet d = CreateObject(scripting.dictionary)定义字典对象For i = 1 To UBound(arr)逐行If Len(arr(i, 2) 0 Then 排出“合计”行，即：姓名务数据If Not d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3) Then d(arr(i, 1) & arr(
9、i, 2) & arr(i, 3) = arr(i, 4) & Chr(9) & arr(i, 5) _& Chr(9) & arr(i, 6) & Chr(9) & arr(i, 7) & Chr(9) & arr(i, 8) & Chr(9) & arr(i, 9) & Chr(9) & arr(i, 10) & Chr(9) & arr(i, 11) & Chr(9) & arr(i, 12)上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能多余)，这个字符串添加 到字典键值，后续的相关属性字段用制表符连接添加到字典条目End IfNextWith Sheets(” 数据
10、存储)lr = .Range(A100000).End(xlUp).Row 数据存储工作表数据行数.Range(C2:D & lr).SpecialCells(xlCellTypeConstants, 23).ClearContents 清除 C、D 列不含公式单元格的 值arr = .Range(A2:l & lr)数据存储工作表数据区域写入数组arrFor i = 1 To UBound(arr)逐行If d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3) Then 如果编码和名称连接字符串字典存在，即Sheet2中有For j = 4 To 12 D、E
11、、F.列逐列If Not Cells(i, j).HasFormula Then Cells(i, j) = Split(d(arr(i, 1) & arr(i, 2), Chr(9)(j - 3)上句：如果单元格不含公式，把Sheet2对应的数据写入这个单元格.Cells(i + 1, j) = Split(d(arr(i, 1) & arr(i, 2) & arr(i, 3), Chr(9)(j - 4)NextEnd IfNextEnd Withr.ClearContentsSheets(数据录入).Cells(4, 3).SelectMsgBox (数据已更新完成，若要查看更新后的内容，请点击按钮查询)End Sub4.清空Sub Clear()I查询内容后，清空单元格Marco， xiaohou制作，时间2013-9-5IDim r As RangeWith Sheets(数据录入)Set r = .Range(c4,e4,d6:l39)End Withr.ClearContentsEnd Sub5.加密隐藏敏感信息、加密保护关键字段，就ok 了
