如何通过EXCEL制作一个录入收集系统
如何通过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 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() '?
' 查询筛选 Macroqq游戏名，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) '笔记本wifi热点逐行?
? ? ? ? 'If Len(arr(i, 2)) <> 0 Then '排出“合计”行，即：姓名务数据?
? ? ? ? ? ? If ists(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)
? '上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能多余)，这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目 ? ? ? ?
?'End If ? ? ?Next?
? ? ?With Sheets("数据存储")?
? ? ?lr = .Range("A100000").End(xlUp).Row '数据存储工作表数据行数?
?'.Range("C2:D" & lr).SpecialCells(xlCellTypeConstants, 23).ClearContents '清除C、D列不含公式单元格的值?
arr = .Range("A2:l" & lr) '数据存储工作表数据区域写入数组arr ? ? ?
For i = 1 To UBound(arr) '逐行?
ists(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) ? ? ? ? ? ? ? ??
?'上句：如果单元格不含公式，把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?("
数据已更新完成，若要查看更新后的内容，请点击按钮查询")

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。