1、用 Excel 建立數(shù)據(jù)錄入系統(tǒng) - 升級版? (2013-09-06 16:02:28)轉(zhuǎn) 載標(biāo)簽： ?分類： ?OFFICEexcelvba一、數(shù)據(jù)采集系統(tǒng)功能錄入、保存、查詢、清空、修改二、兩個界面1. 數(shù)據(jù)錄入界面：前臺功能使用界面，實現(xiàn)“錄入、保存、查詢、清空、修改”；2. 數(shù)據(jù)存儲界面：后臺實現(xiàn)數(shù)據(jù)的保存；錄入界面：三、實現(xiàn)方法1. 保存功能Sub Save()''保存數(shù)據(jù)Marco ，xiaohou 制作，時間2013-9-5'Dim r1, r2, r3 As RangeWith Sheets(" 數(shù)據(jù)存儲 ")Set r2 = .R

2、ange("a2", .a100000.End(xlUp)End WithWith Sheets(" 數(shù)據(jù)錄入 ")Set r1 = .Range("c4:e4, d6:l39")If IsEmpty(.Range("c4") Or IsEmpty(.Range("e4") Then'Or IsEmpty(.Range("b7:b41")添加科室不為空，未成功MsgBox (" 編碼、名稱為空，不可保存！")ElseSet r3 = r2.Find

3、(.Cells(4, 3), , , 1)If Not r3 Is Nothing ThenMsgBox (" 此編碼已存在，不可保存。如果此信息需要修改，請點擊查詢后再修改")ElseSheets("數(shù)據(jù)存儲 ").Rows("2:35").Insert Shift:=xlDown.Range("c6:l39").Copy ' 復(fù)制 “數(shù)據(jù)錄入 ”表體信息Sheets("數(shù)據(jù)存儲 ").Range("c2:l2").PasteSpecial Paste:=xlPas

4、teValues.Range("c4").Copy' 復(fù)制 “數(shù)據(jù)錄入 ”編碼Sheets("數(shù)據(jù)存儲 ").Range("a2:a35").PasteSpecial Paste:=xlPasteValues.Range("e4").Copy' 復(fù)制 “數(shù)據(jù)錄入 ”名稱Sheets("數(shù)據(jù)存儲 ").Range("b2:b35").PasteSpecial Paste:=xlPasteValuesr1.ClearContents'保存數(shù)據(jù)后，清空錄入界

5、面.Range("c4").SelectEnd IfEnd IfEnd WithEnd Sub2. 查詢功能Sub Query()'' 查詢篩選Macro， xiaohou 制作，時間2013-9-5''Dim Erow As IntegerDim r1, r2 As RangeWith Sheets(" 數(shù)據(jù)錄入 ")Set r1 = .Range("d6:l39")Set r2 = .Range("a6:b39")Erow = Sheets("數(shù)據(jù)存儲 ").

6、a100000.End(xlUp).Rowr1.ClearContents'For Each ce In .a2:x2'If ce <> "" Then ce.Value = "*" & ce & "*"'加上通配符 *, 實現(xiàn)模糊查詢'NextIf IsEmpty(.Range("c4") Or IsEmpty(.Range("e4") Then'Or IsEmpty(.Range("b7:b41")添加科

7、室不為空，未成功MsgBox (" 編碼、名稱為空，不可查詢！")ElseSheets("數(shù)據(jù)存儲 ").Range("A1:l" & Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _.c3:e4, CopyToRange:=.A5:l5, Unique:=Falser2.Borders(xlDiagonalDown).LineStyle = xlNoner2.Borders(xlDiagonalUp).LineStyle = xlNoner2.Borde

8、rs(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 = ""'F

9、or Each ce In .a2:x2'If ce <> "" Then ce.Value = Mid(ce, 2, Len(ce) - 2)'取消 "*" 通配符'NextEnd IfEnd WithEnd Sub3. 更新Sub Update()''更新Macro ，xiaohou 制作，時間2013-9-5Dim arr, d As ObjectDim r As RangeDim lr&, i&, j%With Sheets(" 數(shù)據(jù)錄入 ") '查詢

10、修改工作表數(shù)據(jù)區(qū)域?qū)懭霐?shù)組arr'arr = .Range("A7:D" & .Range("A65536").End(xlUp).Row)arr = .Range("a6:l39")Set r = .Range("d6:l39")End WithSet d = CreateObject("scripting.dictionary") ' 定義字典對象For i = 1 To UBound(arr) ' 逐行'If Len(arr(i, 2) <&g

11、t; 0 Then ' 排出 “合計 ”行，即：姓名務(wù)數(shù)據(jù)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) _ & Chr(9) & arr(i, 6) & Chr(9) & arr(i, 7) & Chr(9) & arr(i, 8) & Chr(9) & arr(i, 9) &

12、amp; Chr(9) & arr(i, 10) & Chr(9) &arr(i, 11) & Chr(9) & arr(i, 12)'上一句：如果編碼和名稱連接字符串字典不存在(首次出現(xiàn)，這里判斷可能多余)，這個字符串添加到字典鍵值，后續(xù)的相關(guān)屬性字段用制表符連接添加到字典條目'End IfNextWith Sheets(" 數(shù)據(jù)存儲 ")lr = .Range("A100000").End(xlUp).Row '數(shù)據(jù)存儲工作表數(shù)據(jù)行數(shù)'.Range("C2:D"

13、; & lr).SpecialCells(xlCellTypeConstants, 23).ClearContents '清除 C、 D 列不含公式單元格的值arr = .Range("A2:l" & lr) '數(shù)據(jù)存儲工作表數(shù)據(jù)區(qū)域?qū)懭霐?shù)組arrFor i = 1 To UBound(arr) '逐行If d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3) Then '如果編碼和名稱連接字符串字典存在，即Sheet2 中有For j = 4 To 12 'D 、 E、

14、 F.列逐列'If Not Cells(i, j).HasFormula Then Cells(i, j) = Split(d(arr(i, 1) & arr(i, 2), Chr(9)(j - 3)'上句：如果單元格不含公式，把Sheet2 對應(yīng)的數(shù)據(jù)寫入這個單元格.Cells(i + 1, j) = Split(d(arr(i, 1) & arr(i, 2) & arr(i, 3), Chr(9)(j - 4)NextEnd IfNextEnd Withr.ClearContentsSheets("數(shù)據(jù)錄入 ").Cells(4, 3).SelectMsgBox (" 數(shù)據(jù)已更新完成，若要查看更新后的內(nèi)容，請點擊按鈕查詢&quo