VBA代码：根据模板-按照客户名称-拆分工作表-并拆分工作簿到当前文件夹

ttiemike

请大家帮忙写个VBA代码：1.根据对账单模板-按照客户名称-拆分工作表-并拆分工作簿到当前文件夹，2.对每个工作表计算数量和金额的合计数。谢谢！

shiruiqiang

群里拆分的例子很多，但是想问一下：客户名称重复，为啥不改一个？

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim i As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lh = InputBox("请输入拆分列的列号", "列号", "9")
If lh = "" Then End
hs = InputBox("请输入标题行数", "行数", "1")
If hs = "" Then End
Set sh = ThisWorkbook.Worksheets("模板")
With Sheets("明细查询")
    r = .Cells(Rows.Count, Val(lh)).End(xlUp).Row
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If r < hs + 1 Then MsgBox "数据源为空！": End
    If Val(lh) > y Then MsgBox "输入的列号超出了数据的最大列": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For i = Val(hs) + 1 To UBound(ar)
    If Trim(ar(i, Val(lh))) <> "" Then
        d(Trim(ar(i, Val(lh)))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = Val(hs) + 1 To UBound(ar)
        If Trim(ar(i, Val(lh))) = k Then
            n = n + 1
            br(n, 1) = ar(i, 9)
            br(n, 2) = ar(i, 10)
            For j = 1 To 8
                br(n, j + 2) = ar(i, j)
            Next j
            br(n, 11) = ar(i, 11)
        End If
    Next i
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .Name = k
        .[b3] = k
        .[a6].Resize(n, UBound(br, 2)) = br
        .Rows(n + 6 & ":125").Delete
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

3190496160

根据模板-按照客户名称-拆分工作表-并拆分工作簿到当前文件夹.rar (60.18 KB, 下载次数: 23)

2023-3-8 13:13 上传

点击文件名下载附件

ttiemike

谢谢您的回复，一份对账单只有一个客户名称，名称可以重复。

3190496160

合计数直接写入公式即可，没必要用代码

ttiemike

非常感谢圣侠3190496160，不仅完美解决，并且速度迅速，感恩，钦佩。