如何通过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", .a100000.End(xlUp) End WithWit

2、h 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 = (.Cells(4, 3), , , 1) If Not r3 Is Nothing ThenMsgBox (&

3、quot;此编码已存在，不可保存。如果此信息需要修改，请点击查询后再修改") ElseSheets("数据存储").Rows("2:35").Insert Shift:=xlDown.Range("c6:l39").Copy'复制"数据录入”表体信息Sheets("数据存储").Range("c2:l2").PasteSpecial Paste:=xlPasteValuesRange("c4").Copy '复制"数据录入”编码S

4、heets("数据存储").Range("a2:a35").PasteSpecialPaste:=xlPasteValues.Range("e4").Copy'复制"数据录入”名称Sheets("数据存储").Range("b2:b35").PasteSpecialPaste:=xlPasteValues保存数据后，清空录入界面.Range("c4").Select End If End If End With End Sub2 .查询功能 Sub Quer

5、y()''查询筛选 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'For Each ce In .a2:x2'If ce <> &q

6、uot;" Then = "*" & ce & "*"'加上通配符*,实现模糊查询 'NextIf IsEmpty(.Range("c4") Or IsEmpty(.Range("e4") Then'Or IsEmpty(.Range("b7:b41")添加科室不为空，未成功MsgBox ("编码、名称为空，不可查询！") ElseSheets("数据存储").Range("A1:l"&

7、amp; Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _ .c3:e4, CopyToRange:=.A5:l5, Unique:=F alse(xlDiagonalDown).LineStyle = xlNone (xlDiagonalUp).LineStyle = xl None(xlEdgeLeft).LineStylexlNone(xlEdgeTop).LineStyle = xlNone(xlEdgeBottom).LineStyle = xlNone'(xlEdgeRight).LineStyle =

8、 xlNone (xllnsideVertical).LineStyle = xlNo ne(xllnsideHorizontal).LineStyle = xlNone -"" =；'For Each ce In .a2:x2'If ce <> "" Then = Mid(ce, 2, Len(ce) - 2)'取消"*"通配符'Next End If End With End Sub3 .更新 Sub Update()''更新 Macro , xiaohou 制作，时间

9、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("&quo

10、t;)'定义字典对象For i1 To UBound(arr)'逐行'If Len(arr(i, 2) <> 0 Then '排出“合计”行，即：姓名务数据If Not (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) &a

11、mp; 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 If NextWith Sheets("数据存储")lr = .Range("A100000"

12、).End(xlUp).Row'数据存储工作表数据行数'.Range("C2:D" & lr).SpecialCells(xlCellTypeConstants, 23).ClearContent s '清除C、D列不含公式单元格的值arr = .Range("A2:l" & lr)'数据存储工作表数据区域写入数组arrFor i = 1 To UBound(arr)'逐行If (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)'上句：如果单元格不含公