用E x c e l建立数据录入系统用Excel建立数据录入系统-升级版(2013-09-06 16:02:28)转载▼标签：excelvba分类：OFFICE一、数据采集系统功能录入、保存、查询、清空、修改二、两个界面1. 数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”；2. 数据存储界面：后台实现数据的保存；录入界面：三、实现方法1. 保存功能Sub Save()''保存数据 Marco，xiaohou制作，时间2013-9-5'Dim r1, r2, r3 As RangeWith Sheets("数据存储")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")) Then'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功MsgBox ("编码、名称为空，不可保存！")ElseSet r3 = r2.Find(.Cells(4, 3), , , 1)If Not r3 Is Nothing ThenMsgBox ("此编码已存在，不可保存。

如果此信息需要修改，请点击查询后再修改") 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 Paste:=xlPasteValuesr1.ClearContents '保存数据后，清空录入界面.Range("c4").SelectEnd IfEnd IfEnd WithEnd Sub2. 查询功能Sub Query()'' 查询筛选 Macro，xiaohou制作，时间2013-9-5''Dim Erow As IntegerDim r1, r2 As RangeWith Sheets("数据录入")Set r1 = .Range("d6:l39")Set r2 = .Range("a6:b39")Erow = Sheets("数据存储").[a100000].End(xlUp).Rowr1.ClearContents'For Each ce In .[a2:x2]'If ce <> "" Then ce.Value = "*" & ce & "*" '加上通配符*,实现模糊查询'NextIf IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功MsgBox ("编码、名称为空，不可查询！")ElseSheets("数据存储").Range("A1:l" & Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _ .[c3:e4], CopyToRange:=.[A5:l5], Unique:=Falser2.Borders(xlDiagonalDown).LineStyle = xlNoner2.Borders(xlDiagonalUp).LineStyle = xlNoner2.Borders(xlEdgeLeft).LineStyle = xlNoner2.Borders(xlEdgeTop).LineStyle = xlNoner2.Borders(xlEdgeBottom).LineStyle = xlNone'r2.Borders(xlEdgeRight).LineStyle = xlNoner2.Borders(xlInsideVertical).LineStyle = xlNoner2.Borders(xlInsideHorizontal).LineStyle = xlNoner2.NumberFormatLocal = ";;;"'For Each ce In .[a2:x2]'If ce <> "" Then ce.Value = Mid(ce, 2, Len(ce) - 2) '取消 "*"通配符'NextEnd IfEnd WithEnd Sub3. 更新Sub Update()''更新 Macro，xiaohou制作，时间2013-9-5Dim arr, d As ObjectDim r As RangeDim lr&, i&, j%With Sheets("数据录入") '查询修改工作表数据区域写入数组arr'arr = .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(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("数据存储")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、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()''查询内容后，清空单元格Marco，xiaohou制作，时间2013-9-5'Dim r As RangeWith Sheets("数据录入")Set r = .Range("c4,e4,d6:l39")End Withr.ClearContentsEnd Sub5. 加密隐藏敏感信息、加密保护关键字段，就ok了。