用Excel建立数据录入系统培训讲学
- 格式：doc
- 大小：48.00 KB
- 文档页数：6
当前位置：文档之家 › 用Excel建立数据录入系统培训讲学
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
用E x c e l建立数据录
入系统
用Excel建立数据录入系统-升级版
(2013-09-06 16:02:28)
转载▼
标签：
excel
vba
分类：OFFICE
一、数据采集系统功能
录入、保存、查询、清空、修改
二、两个界面
1. 数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”；
2. 数据存储界面：后台实现数据的保存；
录入界面：
三、实现方法
1. 保存功能
Sub Save()
'
'保存数据 Marco，xiaohou制作，时间2013-9-5
'
Dim r1, r2, r3 As Range
With Sheets("数据存储")
Set r2 = .Range("a2", .[a100000].End(xlUp))
End With
With Sheets("数据录入")
Set r1 = .Range("c4:e4, d6:l39")
If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then
'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功
MsgBox ("编码、名称为空，不可保存！")
Else
Set r3 = r2.Find(.Cells(4, 3), , , 1)
If Not r3 Is Nothing Then
MsgBox ("此编码已存在，不可保存。如果此信息需要修改，请点击查询后再修改") Else
Sheets("数据存储").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:=xlPasteValues
r1.ClearContents '保存数据后，清空录入界面
.Range("c4").Select
End If
End If
End With
End Sub
2. 查询功能
Sub Query()
'
' 查询筛选 Macro，xiaohou制作，时间2013-9-5
'
'
Dim Erow As Integer
Dim r1, r2 As Range
With Sheets("数据录入")
Set r1 = .Range("d6:l39")
Set r2 = .Range("a6:b39")
Erow = Sheets("数据存储").[a100000].End(xlUp).Row
r1.ClearContents
'For Each ce In .[a2:x2]
'If ce <> "" Then ce.Value = "*" & ce & "*" '加上通配符*,实现模糊查询
'Next
If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then
'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功
MsgBox ("编码、名称为空，不可查询！")
Else
Sheets("数据存储").Range("A1:l" & Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _ .[c3:e4], CopyToRange:=.[A5:l5], Unique:=False
r2.Borders(xlDiagonalDown).LineStyle = xlNone
r2.Borders(xlDiagonalUp).LineStyle = xlNone
r2.Borders(xlEdgeLeft).LineStyle = xlNone
r2.Borders(xlEdgeTop).LineStyle = xlNone
r2.Borders(xlEdgeBottom).LineStyle = xlNone
'r2.Borders(xlEdgeRight).LineStyle = xlNone
r2.Borders(xlInsideVertical).LineStyle = xlNone
r2.Borders(xlInsideHorizontal).LineStyle = xlNone
r2.NumberFormatLocal = ";;;"
'For Each ce In .[a2:x2]
'If ce <> "" Then ce.Value = Mid(ce, 2, Len(ce) - 2) '取消 "*"通配符
'Next
End If
End With
End Sub
3. 更新
Sub Update()
'
'更新 Macro，xiaohou制作，时间2013-9-5
Dim arr, d As Object
Dim r As Range
Dim 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 With
Set d = CreateObject("scripting.dictionary") '定义字典对象
For i = 1 To UBound(arr) '逐行
'If Len(arr(i, 2)) <> 0 Then '排出“合计”行，即：姓名务数据