返回目录：excel表格制作
做一个进销存系统吧,很实用的,
示意图如下(共4张)
在<<产品资料>>表G3中输入公式:=IF(B3="","",D3*F3) ,公式下拉.
在<<总进货表>>中F3中输入公式:=
IF(D3="","",E3*INDEX(产品资料!$B$3:$G$170,MATCH(D3,产品资料!$B$3:$B$170,0),3)) ,公式下拉.
在<<总进货表>>中G3中输入公式:=IF(D3="","",F3*IF($D3="","",INDEX(产品资料!$B$3:$G$170,MATCH($D3,产品资料!$B$3:$B$170,0),5))) ,公式下拉.
在<<销售报表>>G3中输入公式:=IF(D3="","",E3*F3) ,公式下拉.
在<<库存e5a48de588b67a686964616f332>>中B3单元格中输入公式:=IF(A3="",0,N(D3)-N(C3)+N(E3)) ,公式下拉.
在<<库存>>中C3单元格中输入公式:=IF(ISNUMBER(MATCH($A3,销售报表!$D$3:$D$100,0)),SUMIF(销售报表!$D$3:$D$100,$A3,销售报表!$E$3:$E$100),"") ,公式下拉.
在<<库存>>中D3单元格中输入公式:=IF(OR(NOT(ISNUMBER(MATCH($A3,总进货单!$D$3:D$100,0))),A3=""),"",SUMIF(总进货单!$D$3:$D$100,$A3,总进货单!$F$3:$F$100)) ,公式下拉.
至此,一个小型的进销存系统就建立起来了.
当然,实际的情形远较这个复杂的多,我们完全可以在这个基础上,进一步完善和扩展,那是后话,且不说它.
这是最简单的.如您需要做大型复杂的进销存系统,我也可以做.感兴趣的话,咱们可以进一步探讨.
有两种方案
1、定制程序，将excel数据批量导来入系统的后台数据库中。自条件是系统是自己定制的，否则一般很难百实现。
2、模拟人工操作，定制程序。类似按键精度灵。问
这些程序工作答量都不低，很难免费服务了。
如果是第2项可以找我做。不过不免费。
看你挂了一天多没人理。
有没有分是次要的，问题能不能说清楚。录入什么，录入以后干什么，求和，归类？
只说录入系统，打开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() '
' 查询筛选 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
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) '逐行
'If Len(arr(i, 2)) <> 0 Then '排出“合计”行，即：姓名务数据
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) & 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 '数据存储工e68a84e8a2ad7a64339作表数据行数
'.Range("C2:D" & lr).SpecialCells(xlCellTypeConstants, 23).ClearContents '清除C、D列不含公式单元格的值
arr = .Range("A2:l" & lr) '数据存储工作表数据区域写入数组arr
For 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、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 ("
数据已更新完成，若要查看更新后的内容，请点击按钮查询")