如何通过EXCEL制作一个录入收集系统.docx
《如何通过EXCEL制作一个录入收集系统.docx》由会员分享，可在线阅读，更多相关《如何通过EXCEL制作一个录入收集系统.docx（5页珍藏版）》请在冰豆网上搜索。
如何通过EXCEL制作一个录入收集系统
如何通过EXCEL制作一个录入收集系统
如何通过EXCEL制作一个录入收集系统？
一、数据采集系统功能录入、保存、查询、清空、修改
二、两个界面
1.数据录入界面：
前台功能使用界面，实现“录入、保存、查询、清空、修改”；
2.数据存储界面：
后台实现数据的保存；录入界面：
三、实现方法1.保存功能SubSave（）'
'保存数据Marco，xiaohou制作，时间2013-9-5'
Dimr1,r2,r3AsRangeWithSheets（"数据存储"）
Setr2=.Range（"a2",.[a100000].End（xlUp））EndWith
WithSheets（"数据录入"） Setr1=.Range（"c4:
e4,d6:
l39"）
IfIsEmpty（.Range（"c4"））OrIsEmpty（.Range（"e4"））Then 'OrIsEmpty（.Range（"b7:
b41"））添加科室不为空，未成功 MsgBox（"编码、名称为空，不可保存！
"） Else
Setr3=r2.Find（.Cells（4,3）,,,1） IfNotr3IsNothingThen
MsgBox（"此编码已存在，不可保存。
如果此信息需要修改，请点击查询后再修改"）
Else
Sheets（"数据存储"）.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:
=xlPasteValues r1.ClearContents '保存数据后，清空录入界面
.Range（"c4"）.Select EndIf EndIfEndWithEndSub
2.查询功能SubQuery（）'
'查询筛选Macro，xiaohou制作，时间2013-9-5''
DimErowAsIntegerDimr1,r2AsRangeWithSheets（"数据录入"） Setr1=.Range（"d6:
l39"） Setr2=.Range（"a6:
b39"）
Erow=Sheets（"数据存储"）.[a100000].End（xlUp）.Row
r1.ClearContents
'ForEachceIn.[a2:
x2]
'Ifce<>""Thence.Value="*"&ce&"*" '加上通配符*,实现模糊查询
'Next
IfIsEmpty（.Range（"c4"））OrIsEmpty（.Range（"e4"））Then
'OrIsEmpty（.Range（"b7:
b41"））添加科室不为空，未成功
MsgBox（"编码、名称为空，不可查询！
"） Else
Sheets（"数据存储"）.Range（"A1:
l"&Erow）.AdvancedFilterAction:
=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=";;;"
'ForEachceIn.[a2:
x2]
'Ifce<>""Thence.Value=Mid（ce,2,Len（ce）-2） '取消"*"通配符
'Next EndIfEndWithEndSub
3.更新SubUpdate（）'
'更新Macro，xiaohou制作，时间2013-9-5
Dimarr,dAsObject
DimrAsRange
Dimlr&,i&,j%
WithSheets（"数据录入"）'查询修改工作表数据区域写入数组arr
'arr=.Range（"A7:
D"&.Range（"A65536"）.End（xlUp）.Row）
arr=.Range（"a6:
l39"）
Setr=.Range（"d6:
l39"）
EndWith
Setd=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）
'上一句：
如果编码和名称连接字符串字典不存在（首次出现，这里判断可能多余），这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目
'EndIf Next
WithSheets（"数据存储"）
lr=.Range（"A100000"）.End（xlUp）.Row'数据存储工作表数据行数
'.Range（"C2:
D"&lr）.SpecialCells（xlCellTypeConstants,23）.ClearContents'清除C、D列不含公式单元格的值
arr=.Range（"A2:
l"&lr）'数据存储工作表数据区域写入数组arr
Fori=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）
Next
End If
Next
End With
r.ClearContents
Sheets（"
数据录入
"）.Cells（4, 3）.Select
MsgBox （"
数据已更新完成，若要查看更新后的内容，请点击按钮查询"）
升级会员 