对账单生成——根据基础数据自动生成对账单

于箱长

G_Jiessie 发表于 2022-11-15 16:38
谢谢大佬指点

你附件换了吗？

G_Jiessie

于箱长 发表于 2022-11-15 16:38
你附件换了吗？

已经换掉了，感谢~

夏天的风shh4695

请测试。。。。。。

夏天的风shh4695

Sub 生成对账单()
t = Time
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, i, j, cnstr, m, n
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cnstr = "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
cn.Open cnstr
Set ws1 = ThisWorkbook.Sheets("汇总")
Set ws2 = ThisWorkbook.Sheets("发货明细")
Set ws3 = ThisWorkbook.Sheets("对账单模板")
arr = ws1.Range("A1:E" & ws1.Cells(Rows.Count, "a").End(xlUp).Row)
For i = LBound(arr) + 1 To UBound(arr)
    m = m + 1
    Application.StatusBar = "一共需要生成" & UBound(arr) - 1 & "份对账单，正在处理第" & m & "份，处理进度：" & Format(m / (UBound(arr) - 1), "0%")
    If Len(Trim(arr(i, 1))) = 0 Then GoTo 100
    Sql = "select 日期,提货单号,合同编号,产品名称,规格型号,计量单位,数量,单价,金额 from [" & ws2.Name & "$] where 售达客户名称='" & arr(i, 1) & "';"
'    Debug.Print Sql
    rs.Open Sql, cn, 1, adLockPessimistic
    n = rs.Clone.RecordCount
    ws3.Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = arr(i, 1)
        .[b3] = "致：" & arr(i, 1)
        .[d9] = arr(i, 2)
        .[d10] = arr(i, 4)
        .[I10] = arr(i, 5)
        .[I9] = arr(i, 3)
        If n > 12 Then .Range("14:14").Resize(n - 12 + 1).Insert xlShiftDown
        .[b13].CopyFromRecordset rs
        rs.Close
    End With
100:
Next i
Set rs = Nothing
cn.Close
Set cn = Nothing
MsgBox "处理完毕！用时" & Format(Time - t, "ss") & "秒！"
Application.StatusBar = ""
End Sub

于箱长

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

真帅啊

G_Jiessie

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

感谢大佬，我测试一下，及时跟你反馈测试结果

G_Jiessie

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

已测试，很方便，语言也很简洁，受教了

熊文来

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

厉害咯。虽然我用不上也不懂VBA。但是必须点赞。

返航

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

WPS怎么运行不了

返航

夏天的风shh4695 发表于 2022-11-15 16:48
请测试。。。。。。

你好WPS运行不了