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

如何通过EXCEL制作一个录入收集系统？一、数据采集系统功能录入、保存、查询、清空、修改二、两个界面1.数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”；2.数据存储界面：后台实现数据的保存；录入界面：三、实现方法1.保存功能SubSave()''保存数据Marco，xiaohou制作，时间2013-9-5'Dimr1,r2,r3AsRangeWithSheets(数据存储)Setr2=.Range(a2,.[a100000].End(xlUp))EndWithWithSheets(数据录入)Setr1=.Range(c4:e4,d6:l39)IfIsEmpty(.Range(c4))OrIsEmpty(.Range(e4))Then'OrIsEmpty(.Range(b7:b41))添加科室不为空，未成功MsgBox(编码、名称为空，不可保存！)ElseSetr3=r2.Find(.Cells(4,3),,,1)IfNotr3IsNothingThenMsgBox(此编码已存在，不可保存。如果此信息需要修改，请点击查询后再修改)ElseSheets(数据存储).Rows(2:35).InsertShift:=xlDown.Range(c6:l39).Copy'复制“数据录入”表体信息Sheets(数据存储).Range(c2:l2).PasteSpecialPaste:=xlPasteValues.Range(c4).Copy'复制“数据录入”编码Sheets(数据存储).Range(a2:a35).PasteSpecialPaste:=xlPasteValues.Range(e4).Copy'复制“数据录入”名称Sheets(数据存储).Range(b2:b35).PasteSpecialPaste:=xlPasteValuesr1.ClearContents'保存数据后，清空录入界面.Range(c4).SelectEndIfEndIfEndWithEndSub2.查询功能SubQuery()''查询筛选Macro，xiaohou制作，时间2013-9-5''DimErowAsIntegerDimr1,r2AsRangeWithSheets(数据录入)Setr1=.Range(d6:l39)Setr2=.Range(a6:b39)Erow=Sheets(数据存储).[a100000].End(xlUp).Rowr1.ClearContents'ForEachceIn.[a2:x2]'IfceThence.Value=*&ce&*'加上通配符*,实现模糊查询'NextIfIsEmpty(.Range(c4))OrIsEmpty(.Range(e4))Then'OrIsEmpty(.Range(b7:b41))添加科室不为空，未成功MsgBox(编码、名称为空，不可查询！)ElseSheets(数据存储).Range(A1:l&Erow).AdvancedFilterAction:=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=;;;'ForEachceIn.[a2:x2]'IfceThence.Value=Mid(ce,2,Len(ce)-2)'取消*通配符'NextEndIfEndWithEndSub3.更新SubUpdate()''更新Macro，xiaohou制作，时间2013-9-5Dimarr,dAsObjectDimrAsRangeDimlr&,i&,j%WithSheets(数据录入)'查询修改工作表数据区域写入数组arr'arr=.Range(A7:D&.Range(A65536).End(xlUp).Row)arr=.Range(a6:l39)Setr=.Range(d6:l39)EndWithSetd=CreateObject(scripting.dictionary)'定义字典对象Fori=1ToUBound(arr)'逐行'IfLen(arr(i,2))0Then'排出“合计”行，即：姓名务数据IfNotd.exists(arr(i,1)&arr(i,2)&arr(i,3))Thend(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)'上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能多余)，这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目'EndIfNextWithSheets(数据存储)lr=.Range(A100000).End(xlUp).Row'数据存储工作表数据行数'.Range(C2:D&lr).SpecialCells(xlCellTypeConstants,23).ClearContents'清除C、D列不含公式单元格的值arr=.Range(A2:l&lr)'数据存储工作表数据区域写入数组arrFori=1ToUBound(arr)'逐行Ifd.exists(arr(i,1)&arr(i,2)&arr(i,3))Then'如果编码和名称连接字符串字典存在，即Sheet2中有Forj=4To12'D、E、F...列逐列'IfNotCells(i,j).HasFormulaThenCells(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)NextEndIfNextEndWithr.ClearContentsSheets(数据录入).Cells(4,3).SelectMsgBox(数据已更新完成，若要查看更新后的内容，请点击按钮查询)