跪求出入库VBA

hehex · 发表于 2012-11-2 23:58

看看这个版本

WJD1163 · 发表于 2012-11-3 03:34

hehex 发表于 2012-11-2 23:58 看看这个版本

这么晚还加班帮我写，真的非常感谢你啊！现在这版本可以了。
我想问一下能不能批量的查找，现在只能一个一个批号来找，能不能实现多批号查找的功能呀？

hehex · 发表于 2012-11-3 10:46

加入了多批号查询，批号之间用半角英文逗号分开。
如果有无效的批号，比如输错了，在前面和中间都无所谓，如果出现在最后会出现无效批号的提示。
不影响使用，就先发上来，前面正确的批号可以正常显示。
即输入: a,b,c 3个批号
假设 a 是错的，b,c 都是正确的，程序可以显示b ,c 的所有记录信息（包括不同仓位）无其他提示
假设 c 是错的，a,b 都是正确的，程序可以显示a,b 所有记录信息，但是会显示错误批号提示窗口（这是个小逻辑bug)。
假设都是错的，无显示，提示错误批号窗口。

WJD1163 · 发表于 2012-11-3 19:38

非常感谢呀!!!!不知大哥还是姐姐,呵呵!!!
有了这个以后查询就方便了!!!!哈哈
你帮我看一下还有个什么可能改良的地方吗????{:soso_e100:}

hehex · 发表于 2012-11-4 22:34

看来脑子乱的时候就是不能写代码，上周5 工作抽空写的代码有几处逻辑bug，特别是自查模块和入库模块。
今天回来修正了一下，彻底重写了自查模块。

WJD1163 · 发表于 2012-11-5 02:12

本帖最后由 WJD1163 于 2012-11-5 03:02 编辑

hehex 发表于 2012-11-4 22:34 看来脑子乱的时候就是不能写代码，上周5 工作抽空写的代码有几处逻辑bug，特别是自查模块和入库模块。今天 ...

呵有劳兄弟了，真想自已学下VbA，可惜英语水平不好呀！
我看到你自查那代码里，有部份注释了，如果我只想只保留一个批号，是不是启用那代码啊？

hehex · 发表于 2012-11-5 10:31

WJD1163 发表于 2012-11-5 02:12
呵有劳兄弟了，真想自已学下VbA，可惜英语水平不好呀！
我看到你自查那代码里，有部份注释了，如果我只想 ...

目前没有基于批号单条件的，以前的版本是。现在是只保留一个批号并且相同仓位的记录，同批号不同仓位的记录是分别保留的。
目前自查是在入库最后自动调用的，当然你可以修改代码实现手动自查。
就是在入库最后把call 自查这句话前面加上' 注释掉。这样你的入库单到数据库是不会合并保留原样的。然后可以在数据库sheet 上建立一个按钮,右键绑定宏，绑上自查宏即可。

hehex · 发表于 2012-11-5 10:34

WJD1163 发表于 2012-11-5 02:12
呵有劳兄弟了，真想自已学下VbA，可惜英语水平不好呀！
我看到你自查那代码里，有部份注释了，如果我只想 ...

上面注释的代码是上周写的，思路没问题，但是代码实现上有问题，工余做的，一遍得应付工作，有逻辑bug。
用那代码的思路继续做也可以，重写决定用数组和字典对象来做，如果记录多的话执行速度要比单元格访问快很多。

WJD1163 · 发表于 2012-11-5 11:42

如果只保存单条的话,要改那个代码呀?要怎样改呀??{:soso_e132:}

hehex · 发表于 2012-11-5 13:07

本帖最后由 hehex 于 2012-11-5 13:08 编辑

WJD1163 发表于 2012-11-5 11:42
如果只保存单条的话,要改那个代码呀?要怎样改呀??

单条件批号自查模块可以参考本贴13楼那个无错的附件内相关代码，是用单元格区域对象写的。
下面这个是用数组和字典对象写的只保留单条件批号的代码。

Sub 自查()
'数据库表自查程序，如果有相同批号记录就合并数量，并删除重复批号行，
'只保留第一行批号出现记录，仓位数据无实际意义了。
Dim ar() As Variant, br() As Variant, d As Object, i%, cr() As Variant, j%, m%
Sheet4.Activate
ar = Range("a1").CurrentRegion
Set d = CreateObject("scripting.dictionary") '定义字典对象
For i = 2 To UBound(ar)
If ar(i, 3) <> "" Then d(ar(i, 3)) = d(ar(i, 3)) + ar(i, 4) '单条件批号读入字典，Key: 批号, Item: 该批号对应的所有记录数量和
Next
ReDim br(1 To d.Count, 1 To 8)
ReDim cr(1 To d.Count, 1 To 2)
cr = WorksheetFunction.Transpose(Array(d.keys, d.items))
For i = 1 To UBound(br)
'j = InStr(cr(i, 1), ",")
br(i, 3) = cr(i, 1) '读入不重复的批号进数组br 第3列
'br(i, 5) = Mid(cr(i, 1), j + 1, Len(cr(i, 1)) - j)
br(i, 4) = cr(i, 2) '将合计数量读入br 第4列
Next
For j = 1 To UBound(br)
For i = 2 To UBound(ar)
If (br(j, 3) = ar(i, 3)) Then
br(j, 1) = ar(i, 1)
br(j, 2) = ar(i, 2)
br(j, 3) = ar(i, 3)
br(j, 5) = ar(j, 5)
br(j, 6) = ar(i, 6)
br(j, 7) = ar(i, 7)
br(j, 8) = ar(i, 8)
End If
Next
Next
Range("a2:h8").ClearContents
Range("a2").Resize(UBound(br), 8) = br
Set d = Nothing
Erase ar: Erase br: Erase cr
End Sub

复制代码

		自动登录	找回密码
密码			免费注册