[已解决]插入式照模板生成账单工作簿

图不安兔

老师们：晚上好！恳请帮忙修改附件里的VBA代码，使之实现一键自动生成各个客户账单工作簿，多谢！！！

最佳答案

月排行榜 / 总排行榜

哥儿-

2022-12-3 21:28

你测试一下看是否符合要求
Sub test()
    Dim vArr, brr, crr, dic As Object, sht As Worksheet
    Dim i%, j%, num%, shp As Shape, wb As Workbook, k, drr, n, t
    vArr = Sheet1.Range("A1").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    Set sht = Sheet2
    t = Timer
    For i = 2 To UBound(vArr)
        dic(vArr(i, 5)) = dic(vArr(i, 5)) & "\" & i
    Next i
    For Each shp In Sheet2.Shapes
        shp.Delete
    Next shp
    drr = Array("单据编号", "日期", "产品名称", "规格型号", "单位", "实发数量", "销售单价", "销售金额", "备注")
    For Each k In dic.keys
        brr = Split(dic(k), "\")
        ReDim crr(1 To UBound(brr), 1 To 9)
        For i = 0 To UBound(drr) - 1
            For j = 1 To UBound(brr)
                For n = 1 To UBound(vArr, 2)
                    If vArr(1, n) = drr(i) Then crr(j, i + 1) = vArr(--brr(j), n)
                Next n
                crr(j, 9) = crr(j, 7) * crr(j, 8)
            Next j
        Next i
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Set wb = Workbooks.Add
        sht.Cells.Copy wb.Sheets(1).[a1]
        With wb.Sheets(1)
            .Rows(4).Resize(UBound(crr) - 3).Insert
            .[a4].Resize(UBound(crr), 9) = crr
        End With
        wb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
        wb.Close True
    Next k
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "处理完成，用时：" & Timer - t & "秒"
End Sub

跳转到最佳答案楼层

哥儿-

你测试一下看是否符合要求
Sub test()
    Dim vArr, brr, crr, dic As Object, sht As Worksheet
    Dim i%, j%, num%, shp As Shape, wb As Workbook, k, drr, n, t
    vArr = Sheet1.Range("A1").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    Set sht = Sheet2
    t = Timer
    For i = 2 To UBound(vArr)
        dic(vArr(i, 5)) = dic(vArr(i, 5)) & "\" & i
    Next i
    For Each shp In Sheet2.Shapes
        shp.Delete
    Next shp
    drr = Array("单据编号", "日期", "产品名称", "规格型号", "单位", "实发数量", "销售单价", "销售金额", "备注")
    For Each k In dic.keys
        brr = Split(dic(k), "\")
        ReDim crr(1 To UBound(brr), 1 To 9)
        For i = 0 To UBound(drr) - 1
            For j = 1 To UBound(brr)
                For n = 1 To UBound(vArr, 2)
                    If vArr(1, n) = drr(i) Then crr(j, i + 1) = vArr(--brr(j), n)
                Next n
                crr(j, 9) = crr(j, 7) * crr(j, 8)
            Next j
        Next i
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Set wb = Workbooks.Add
        sht.Cells.Copy wb.Sheets(1).[a1]
        With wb.Sheets(1)
            .Rows(4).Resize(UBound(crr) - 3).Insert
            .[a4].Resize(UBound(crr), 9) = crr
        End With
        wb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
        wb.Close True
    Next k
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "处理完成，用时：" & Timer - t & "秒"
End Sub

zjdh

在你的代码上稍作修改
2022年应收账款明细 - 出账单.rar (28.06 KB, 下载次数: 13)

2022-12-3 21:46 上传

点击文件名下载附件

图不安兔

哥儿- 发表于 2022-12-3 21:28
你测试一下看是否符合要求
Sub test()
    Dim vArr, brr, crr, dic As Object, sht As Worksheet

衷心感谢您！哥儿老师！！谢谢！！！

图不安兔

zjdh 发表于 2022-12-3 21:46
在你的代码上稍作修改

谢谢您！zjdh老师！！衷心感想您！！！

图不安兔

哥儿老师和zjdh老师，您两位的代码非常完美，让我不知道将最佳答案贴哪一位了。这下还难为……

哥儿-

图不安兔 发表于 2022-12-4 07:21
哥儿老师和zjdh老师，您两位的代码非常完美，让我不知道将最佳答案贴哪一位了。这下还难为……

这有什么好为难的，直接给zjdh大佬就是了，改代码才是技术活，而且也方便你维护。

zjdh

不要，我已经有不少“最佳”了，给 “哥儿” 吧。

图不安兔

衷心感谢两位老师高风亮节！！！