如何一键生成各日出库单

定敏

我有一套表，是学生食堂就餐用的出库单，分两部分，一个是营养餐部分，一是非营养餐部分，在我们去上级报账时，得把各天的出库单打印出来，比如我要打营养餐系列的全个月的，就得一天一天地点出库时间的下拉列表（一张有两天），然后打印一张，然后再分别点第三天和第四天有记录的，再打第二张，很麻烦，可不可以实现像邮件合并那样，一键把一个月所有的出库单生成一个word文件，再一次性打印，就方便多了，想来如此复杂的操作只有VBA才能实现此功能，但我不会VBA,只好求助于老师们，谢谢。
book1.rar (124.87 KB, 下载次数: 32)

2023-2-16 14:46 上传

点击文件名下载附件

chengyunpan

附件无法下载

定敏

chengyunpan 发表于 2023-2-16 14:43
附件无法下载

可以下载的呀，我也重新上传了。

chengyunpan

还是不行，刚才下载别人的就行

扑腾

明白意识了，就是根据数据源还原指定日期的出库单 。对吧？

定敏

扑腾 发表于 2023-2-16 15:15
明白意识了，就是根据数据源还原指定日期的出库单 。对吧？

对，就是把整个月的所有天的出库单一次性生成出来。由于有两种数据，一是营养餐，一是非营养餐（那个学前的不用了），所以想实现一次性生成前两种出库单。

3190496160

比较繁琐，先留个记号吧

3190496160

Sub 出库单()
Application.ScreenUpdating = False
With Sheets("出库单")
    lx = Mid(.[i1], 2, Len(.[i1]) - 3)
    mc = lx & "出库登记表"
    With Sheets(mc)
        r = .Cells(Rows.Count, 3).End(xlUp).Row
        ar = .Range("a1:am" & r)
    End With
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs > 17 Then .Rows("18:" & rs).Delete
    For j = 5 To 35
        n = 0
        ReDim br(1 To UBound(ar), 1 To 5)
        If Trim(ar(2, j)) <> "" Then
            For i = 8 To UBound(ar)
                If Trim(ar(i, j)) <> "" Then
                    n = n + 1
                    br(n, 1) = Replace(ar(i, 3), "上月结余", "")
                    br(n, 2) = ar(i, 38)
                    br(n, 3) = ar(i, j)
                    br(n, 4) = ar(i, 39)
                    br(n, 5) = br(n, 4) * br(n, 5)
                End If
            Next i
            If n > 0 Then
                m = m + 1
                If m = 1 Then
                    .[c2] = ar(2, j)
                    .[g2] = ar(6, j)
                    .[i2] = ar(5, j)
                    .[l2] = ar(4, j)
                    If n <= 10 Then
                        .[b4].Resize(n, 5) = br
                    Else
                        k = 3
                        For i = 1 To 10
                            k = k + 1
                            For jj = 1 To 5
                                .Cells(k, jj + 1) = br(i, jj)
                            Next jj
                        Next i
                        k = 3
                        For i = 11 To n
                            k = k + 1
                            For jj = 1 To 5
                                .Cells(k, jj + 7) = br(i, jj)
                            Next jj
                        Next i
                    End If
                ElseIf m > 1 Then
                    ws = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                    .Rows("1:17").Copy .Cells(ws, 1)
                    .Cells(ws + 1, 3) = ar(2, j)
                    .Cells(ws + 1, 7) = ar(6, j)
                    .Cells(ws + 1, 9) = ar(5, j)
                    .Cells(ws + 1, 12) = ar(4, j)
                    If n <= 10 Then
                        .Cells(ws + 3, 2).Resize(n, 5) = br
                    Else
                        k = ws + 2
                        For i = 1 To 10
                            k = k + 1
                            For jj = 1 To 5
                                .Cells(k, jj + 1) = br(i, jj)
                            Next jj
                        Next i
                        k = ws + 2
                        For i = 11 To n
                            k = k + 1
                            For jj = 1 To 5
                                .Cells(k, jj + 7) = br(i, jj)
                            Next jj
                        Next i
                    End If
                End If
            End If
        End If
    Next j
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

book.rar (183.28 KB, 下载次数: 21)

2023-2-16 17:15 上传

点击文件名下载附件

3190496160

下班了，很多细节未考虑，代码仅供参考