按关键字做表格分拆

kinoshen

各位大侠，麻烦帮我编一段宏，要求是工作薄示例中有各个客户的明细，另外有一个sheet是需要分拆的客户清单。

要求运行宏后，自动分拆按需要分拆的客户明细为单独的工作薄，文件名的命名格式是：日期-客户名称-汇总实收金额（元）。
其中日期取值：B列，B列所有的日期都是相同的。客户名称取值：D列，汇总实收金额取值计算J列。
新生成的文件保存在原文件目录下面即可。

上传附件：工作簿示例是原始的需要按条件拆分的表格。另外一个是拆分后的示例文件。

microyip

论坛里有很多拆分案例，你都接触VBA快6年了，搜索一下参考

3190496160

这个拆分工具完全可以满足你的需求，下载就能用
【新提醒】Excel 灵活拆分工具之四-ExcelVBA程序开发-ExcelHome技术论坛 -  http://club.excelhome.net/thread-1548093-1-1.html

笨鸟飞不高

Sub SplitToWsb()   'by ***笨鸟飞不高***
    Dim i%, j%, qrz%, xh%, hjh%, cfl%, bth%, r%, k%, m%, hjStr$, tStr$, ScStr$, fName$
    Dim rng As Range, rngs As Range, ws As Worksheet, wb As Workbook
    Dim arr, tempAr, hjAr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    qrz = MsgBox("当前是否选择了拆分总表？", vbYesNo)
    If qrz = 7 Then Exit Sub
    On Error Resume Next
        Set rng = Application.InputBox("请选择带标题行的拆分数据区域", Type:=8)
        If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    Application.ScreenUpdating = False
    If rng.Count < 2 Then Exit Sub
    arr = rng
    xh = MsgBox("拆分区域的第一列是否为序号列？", vbYesNo)
    hjh = MsgBox("拆分的分表是否要加合计行？", vbYesNo)
    If hjh = 6 Then
        hjStr = InputBox("请输入合计数据在拆分区域中所对应的列数,如果是多列，以""@""符号分开", "提示")
    End If
    cfl = Val(InputBox("请输入拆分关键字在拆分区域中所对应的列数", "提示"))
    If cfl < LBound(arr, 2) Or cfl > UBound(arr, 2) Then Exit Sub
    bth = Val(InputBox("请输入标题行在拆分区域中的行数", "提示"))
    If bth > 0 Then Set rngs = Cells(rng(1).Row, rng(1).Column).Resize(bth, UBound(arr, 2))
    ScStr = InputBox("拆分输出到工作表还是工作簿 ?", "提示", "工作表")
    If ScStr <> "工作表" And ScStr <> "工作簿" Then Exit Sub
    Application.DisplayAlerts = False
    If ScStr = "工作表" Then
        For Each ws In Sheets
            If ws.Name <> ActiveSheet.Name Then ws.Delete
        Next
    End If
    If ScStr = "工作簿" Then
        qrz = MsgBox("此操作将会覆盖目标文件夹内同名的工作簿！", vbYesNo)
        If qrz = 7 Then Exit Sub
    End If
    For i = bth + 1 To UBound(arr)
        If Len(arr(i, cfl)) Then d(arr(i, cfl)) = d(arr(i, cfl)) & "," & i
    Next
    For i = bth + 1 To UBound(arr)
        If d.exists(arr(i, cfl)) Then
            If Not d.exists(arr(i, cfl) & "|Sc") Then
                r = 0: d(arr(i, cfl) & "|Sc") = "": tStr = d(arr(i, cfl)): tempAr = Split(tStr, ",")
                ReDim ScAr(1 To UBound(tempAr) + 1, 1 To UBound(arr, 2))
                If hjh = 6 Then ScAr(UBound(ScAr), 1) = "合计"
                For k = 1 To UBound(tempAr)
                    r = r + 1
                    If xh = 6 Then
                        ScAr(r, 1) = r
                        For j = 2 To UBound(arr, 2): ScAr(r, j) = arr(tempAr(k), j): Next
                        If hjh = 6 Then
                            hjAr = Split(hjStr, "@")
                            For m = 0 To UBound(hjAr)
                                ScAr(UBound(ScAr), Val(hjAr(m))) = ScAr(UBound(ScAr), Val(hjAr(m))) _
                                    + arr(tempAr(k), Val(hjAr(m)))
                            Next
                        End If
                    Else
                        For j = 1 To UBound(arr, 2): ScAr(r, j) = arr(tempAr(k), j): Next
                        If hjh = 6 Then
                            hjAr = Split(hjStr, "@")
                            For m = 0 To UBound(hjAr)
                                ScAr(UBound(ScAr), Val(hjAr(m))) = ScAr(UBound(ScAr), Val(hjAr(m))) _
                                    + arr(tempAr(k), Val(hjAr(m)))
                            Next
                        End If
                    End If
                Next
            If ScStr = "工作表" Then
                With Worksheets.Add(, Sheets(Sheets.Count))
                    .Name = Trim(arr(i, cfl))
                    If bth > 0 Then rngs.Copy .[a1].Resize(bth, UBound(ScAr, 2))
                    With .Range("A" & bth + 1).Resize(UBound(ScAr), UBound(ScAr, 2))
                        .Borders.Weight = xlThin
                        .HorizontalAlignment = xlCenter
                        .Font.Name = "宋体"
                        .Font.Size = 10
    '                    .NumberFormatLocal = "@"
                        .Value = ScAr
                    End With
                End With
            ElseIf ScStr = "工作簿" Then
                Set wb = Workbooks.Add
                If bth > 0 Then rngs.Copy Workbooks(Workbooks.Count).Sheets(1).[a1].Resize(bth, UBound(ScAr, 2))
                With Workbooks(Workbooks.Count).Sheets(1).Range("A" & bth + 1).Resize(UBound(ScAr), UBound(ScAr, 2))
                    .Borders.Weight = xlThin
                    .HorizontalAlignment = xlCenter
                    .Font.Name = "宋体"
                    .Font.Size = 10
    '                    .NumberFormatLocal = "@"
                    .Value = ScAr
                End With
                fName = ThisWorkbook.Path & "\" & Trim(arr(i, cfl)) & ".xlsx"
                wb.SaveAs fName
                wb.Close
            End If
            End If
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

代码供参考！！！

kinoshen

microyip 发表于 2020-12-5 10:43
论坛里有很多拆分案例，你都接触VBA快6年了，搜索一下参考

我懒啊，怕学。

kinoshen

3190496160 发表于 2020-12-5 12:13
这个拆分工具完全可以满足你的需求，下载就能用
【新提醒】Excel 灵活拆分工具之四-ExcelVBA程序开发-Exce ...

首先我我希望不是所有的数据都拆分，只拆分指定的关键客户，拆分之后自动保存在电脑上，而且文件名必须要按我的要求来命名。所以有点纠结。

kinoshen

3190496160 发表于 2020-12-5 12:13
这个拆分工具完全可以满足你的需求，下载就能用
【新提醒】Excel 灵活拆分工具之四-ExcelVBA程序开发-Exce ...

最好是帮我写一段简单的代码，我这个文件什么格式列数，表头名称等都是一成不变的。

kinoshen

我是想要拆分成这样一个文件名，否则再好的拆分工具对我来说也是没用，因为这个文件是发给客户的，同时在以后使用过程中，不需要打开这个文件，就可以知道当天这个客户的费用情况。

3190496160

现成的工具给你不想用，那就出钱定制呗

lsc900707

kinoshen 发表于 2020-12-6 10:49
我懒啊，怕学。

意思就是我懒，所以想找免费的代工呗！