入库单录入及优化求助大神

hqiang133

如图，希望可以优化入库单的一些内容，比如供应商增加到供应商基础信息表，包括材料

以及入库单功能的一些其他优化
跪求大神解决！
拜谢！！！

3190496160

附件上传错了吧？目前的附件中一句代码都没有的嘛

3190496160

入库单  工作表内，有何要两个入库单表格呢？？？？

hqiang133

3190496160 发表于 2024-3-14 09:50
入库单  工作表内，有何要两个入库单表格呢？？？？

不好意思，可能传错了，下午我重新上传一下

hqiang133

hqiang133 发表于 2024-3-14 09:56
不好意思，可能传错了，下午我重新上传一下

两个入库单我是为了打印两份出来，因为打印的是a4，不是正规的那种几联制式入库单，因为我现在在外面看不了附件，有问题的话得晚点上传了

3190496160

Sub 入库保存()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim rn As Range
With Sheets("供应商信息汇总")
    ws = .Cells(Rows.Count, 1).End(xlUp).Row
    If ws > 2 Then
        cr = .Range("a2:a" & ws)
        For i = 2 To UBound(cr)
            If cr(i, 1) <> "" Then
                d(cr(i, 1)) = ""
            End If
        Next i
    End If
End With
With Sheets("物料名称表")
    ms = .Cells(Rows.Count, 1).End(xlUp).Row
    If ms > 2 Then
        crr = .Range("a2:d" & ms)
        For i = 2 To UBound(crr)
            If crr(i, 1) <> "" Then
                zd = crr(i, 1) & "|" & crr(i, 2) & "|" & crr(i, 3) & "|" & crr(i, 4)
                dc(zd) = ""
            End If
        Next i
    End If
End With

With Sheets("入库单")
    r = [c5].End(xlDown).Row
    If r = 16 Then MsgBox "入库单为空，请先录入数据！": End
    ar = .Range("a1:l16")
    xm = .[d2]
    If xm = "" Then MsgBox "项目名称为空！": End
    jbr = .[i2]
    If jbr = "" Then MsgBox "经办人称为空！": End
    dw = .[d3]
    If dw = "" Then MsgBox "供货单位为空！": End
    dh = .[L2]
    If dh = "" Then MsgBox "入库单号为空！": End
End With
Dim br()
ReDim br(1 To UBound(ar), 1 To 15)
ReDim arr(1 To UBound(ar), 1 To 4)
For i = 6 To 15
    If ar(i, 3) <> "" Then
        n = n + 1
        br(n, 1) = ar(1, 12)
        br(n, 2) = ar(3, 9)
        br(n, 3) = ar(3, 9)
        br(n, 4) = ar(3, 4)
        br(n, 5) = ar(i, 3)
        For j = 5 To 12
            br(n, j + 1) = ar(i, j)
        Next j
        br(n, 14) = ar(2, 12)
        br(n, 15) = ar(2, 9)
        
        zd = ar(i, 3) & "|" & ar(i, 5) & "|" & ar(i, 6) & "|" & ar(i, 7)
        If Not dc.exists(zd) Then
            m = m + 1
            arr(m, 1) = ar(i, 3)
            arr(m, 2) = ar(i, 5)
            arr(m, 3) = ar(i, 6)
            arr(m, 4) = ar(i, 7)
        End If
    End If
Next i
If n = "" Then MsgBox "入库单为空，请先录入数据！": End
If Not d.exists(dw) Then Sheets("供应商信息汇总").Cells(ws + 1, 1) = dw
If m <> "" Then Sheets("物料名称表").Cells(ms + 1, 1).Resize(m, 4) = arr
With Sheets("入库流水表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    Set rn = .Range("n2:n" & rs - 1).Find(dh, , , , , , 1)
    If Not rn Is Nothing Then MsgBox "不能重复录入！": End
    .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
End With
ww = Val(Right([L2], 4)) + 1
[L2] = "RK" & Format(ww, "0000")
MsgBox "录入完毕！", 64, "提醒！"
End Sub

3190496160

入库单求助.rar (53.44 KB, 下载次数: 30)

2024-3-14 10:46 上传

点击文件名下载附件

hqiang133

3190496160 发表于 2024-3-14 10:46

谢谢，等晚上看看，非常感谢您的帮助