用Excel建立数据录入系统

用Excel建立数据录入系统-升级版

?(2013-09-06 16:02:28)

转载

分类：?OFFICE

标签：?

excel

vba

一、数据采集系统功能

录入、保存、查询、清空、修改

二、两个界面

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 '排出“合计”行，即：姓名务数据

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)

'上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能多余)，这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目