如何通过EXCEL制作一个录入收集系统

1、如何通过EXCEL制作一个录入收集系统？一、数据采集系统功能 录入、保存、查询、清空、修改 二、两个界面 1.数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”；2. 数据存储界面：后台实现数据的保存； 录入界面：三、实现方法 1. 保存功能 Sub Save() ' '保存数据 Marco，xiaohou制作，时间2013-9-5 ' Dim r1, r2, r3 As Range With Sheets("数据存储") Set r2 = .Range("a2"

2、, .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 ("编码、

3、名称为空，不可保存！")   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"

4、).Copy  '复制“数据录入”表体信息 Sheets("数据存储").Range("c2:l2").PasteSpecial Paste:=xlPasteValues       .Range("c4").Copy      '复制“数据录入”编码 Sheets("数据存储").Range("a2:a35").PasteSpecial Paste:=xlPasteValues  

5、;     .Range("e4").Copy      '复制“数据录入”名称 Sheets("数据存储").Range("b2:b35").PasteSpecial Paste:=xlPasteValues       r1.ClearContents       '保存数据后，清空录入界面       .Range("c4").Sele

6、ct     End If   End If End With End Sub2. 查询功能 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") 

7、;Erow = Sheets("数据存储").a100000.End(xlUp).Row     r1.ClearContents     'For Each ce In .a2:x2 'If ce <> "" Then ce.Value = "*" & ce & "*"   '加上通配符*,实现模糊查询     'Next If IsE

8、mpty(.Range("c4") Or IsEmpty(.Range("e4") Then     'Or IsEmpty(.Range("b7:b41") 添加科室不为空，未成功     MsgBox ("编码、名称为空，不可查询！")   Else Sheets("数据存储").Range("A1:l" & Erow).AdvancedFilter Action:=xlFil

9、terCopy, 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).LineS

10、tyle = xlNone     r2.Borders(xlEdgeBottom).LineStyle = xlNone     'r2.Borders(xlEdgeRight).LineStyle = xlNone     r2.Borders(xlInsideVertical).LineStyle = xlNone r2.Borders(xlInsideHorizontal).LineStyle = xlNone     r2.NumberFormatLocal

11、 = ""     'For Each ce In .a2:x2  'If ce <> "" Then ce.Value = Mid(ce, 2, Len(ce) - 2)   '取消 "*"通配符    'Next   End If End With End Sub3. 更新 Sub Update() ' '更新 Macro，xiaohou制作，时间2013-9-5

12、      Dim arr, d As Object      Dim r As Range      Dim lr&, i&, j%      With Sheets("数据录入") '查询修改工作表数据区域写入数组arr          'arr = .Range("A7:D" & .Range("A65536").End

13、(xlUp).Row)           arr = .Range("a6:l39")           Set r = .Range("d6:l39")      End With Set d = CreateObject("scripting.dictionary") '定义字典对象      For i = 1 To UBound

14、(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)

15、 _             & 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)  '上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能

16、多余)，这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目         'End If      Next      With Sheets("数据存储")      lr = .Range("A100000").End(xlUp).Row '数据存储工作表数据行数  '.Range("C2:D" &

17、lr).SpecialCells(xlCellTypeConstants, 23).ClearContents '清除C、D列不含公式单元格的值 arr = .Range("A2:l" & lr) '数据存储工作表数据区域写入数组arr      For i = 1 To UBound(arr) '逐行 If d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3) Then '如果编码和名称连接字符串字典存在，即Sheet2中有  

18、;           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,