签收单的批量生成，求助！！！

一一如终

求助签收单的批量导出~


根据S列运输委托单号（香港段），来批量导出签收单模板，一个运输委托单号（香港段）号生成一个签收单。
签收单需要如下5个数据
1.运输委托单号（香港段）
2.日期：（数据源的A列）
3.件数：合计同一个运输委托单号（香港段）的总件数（数据源的I列）
4.SO：（数据源的K列）
5.收货人公司地址：数据源的L列


导出的签收单命名以运输委托单号（香港段）号+后缀签收单来命名。

nicleyuan

                                 


FYI

蓝桥玄霜

把签收单模板的表格1复制到数据源工作簿里面，表格名还是“Sheet1”不变。
录入代码，执行即可。

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br, i&, n&, dic As Object, vKey, t#
    Dim strFileName$, strPath$, strName$, wks As Worksheet
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "签收单模板.xlsx"
    If Dir(strFileName) = "" Then MsgBox "模板文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
    For i = 2 To UBound(ar)
        vKey = ar(i, 19)
        dic(vKey) = dic(vKey) & " " & i
    Next i
    With GetObject(strFileName)
        Set wks = .Sheets(1)
        For Each vKey In dic.keys
            br = Split(dic(vKey)): n = 0
            For i = 1 To UBound(br)
                n = n + ar(br(i), 9)
            Next i
            wks.Copy
            strName = strPath & "签收单\" & vKey & "签收单"
            With ActiveWorkbook
                With .Sheets(1)
                    .Cells(2, 1) = ar(br(1), 1)
                    .Cells(2, 2) = ar(br(1), 11)
                    .Cells(2, 3) = vKey
                    .Cells(2, 4) = n
                    .Cells(3, 3) = ar(br(1), 12)
                End With
                .SaveAs strName
                .Close
            End With
        Next
        .Close False
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

代码审核中，请参考附件。。。

熊文来

好文件，以后有可能能用得上，留个脚印