将工作表中的多个工作簿按照产品来拆分，结果应是按产品多工作簿的工作表。

izouxu

要求1、拆分出来的单个工作表中多工作簿的命名和原表一致；

要求2、拆分出来的单个工作表的命名应是“A01+产品名称”、“A02+产品名称”以此类推；
最好可以扩展，万一表格有更改多加工作簿或者内容筛选变更了，这种方式也同样可以使用。
红包感谢！

izouxu

补充一个要求，拆分完成在原表格多个工作簿中是否导出一列填写是

3190496160

1、楼主工作表和工作簿弄反了吧
2、目前的文件所有的工作表都是空的，只有一行列标题，是没有办法写代码和测试代码的

3190496160

Sub 拆分为多薄多表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim rn As Range, rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    y = sh.Cells(1, Columns.Count).End(xlToLeft).Column
    Set rn = sh.Rows("1:2").Find("产品名称", , , , , , 1)
    If rn Is Nothing Then MsgBox sh.Name & "工作表的第一行没有  产品名称  字段，请核查后重试！": End
    h = rn.Column
    r = sh.Cells(Rows.Count, h).End(xlUp).Row
    ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
    For i = 2 To UBound(ar)
        If Trim(ar(i, h)) <> "" Then
            d(Trim(ar(i, h))) = ""
        End If
    Next i
Next sh
For Each k In d.keys
    m = 0
    For Each sh In Sheets
        m = m + 1
        y = sh.Cells(1, Columns.Count).End(xlToLeft).Column
        Set rn = sh.Range("a1").Resize(2, y).Find("产品名称", , , , , , 1)
        If rn Is Nothing Then MsgBox sh.Name & "工作表的第一行没有  产品名称  字段，请核查后重试！": End
        h = rn.Column
        r = sh.Cells(Rows.Count, h).End(xlUp).Row
        ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
        If m = 1 Then
            sh.Copy
            Set wb = ActiveWorkbook
        Else
            sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
        End If
        With wb.ActiveSheet
            For i = 2 To UBound(ar)
                If Trim(ar(i, h)) <> k Then
                    If rng Is Nothing Then
                        Set rng = .Rows(i)
                    Else
                        Set rng = Union(rng, .Rows(i))
                    End If
                End If
            Next i
        End With
        If Not rng Is Nothing Then rng.Delete
        Set rng = Nothing
    Next sh
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

2023年汇总报表-样表.rar (1.36 MB, 下载次数: 4)

2024-1-19 13:11 上传

点击文件名下载附件

3190496160

没有具体的数据，没法测试代码正确与否，实在不行，可以加我v

izouxu

添加了点内容的样表，由于有些信息安全问题删除了部分内容。请见谅

izouxu

3190496160 发表于 2024-1-19 12:50
1、楼主工作表和工作簿弄反了吧
2、目前的文件所有的工作表都是空的，只有一行列标题，是没有办法写代码和 ...

已上传部分内容的样表

3190496160

izouxu 发表于 2024-1-19 13:35
已上传部分内容的样表

已经给你代码了，自己把代码拷贝到你的文件中就可以测试了呀