工作表拆分求老师帮忙

hcunicom

yysfcq1 发表于 2024-4-3 07:26
老师帮帮我一定送上鲜花

鲜花遍地是
无人在乎它

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("数据表")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 3 Then MsgBox "数据表为空！": End
    ar = .Range(.Cells(2, 1), .Cells(r, 9))
End With
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        If InStr(ar(i, 1), "汇总") = 0 Then
            If d(ar(i, 1)) = "" Then
                d(ar(i, 1)) = i
            Else
                d(ar(i, 1)) = d(ar(i, 1)) & "|" & i
            End If
        End If
    End If
Next i
For Each k In d.keys
    rr = Split(d(k), "|")
    n = 0: hj = 0
    ReDim br(1 To UBound(ar), 1 To 12)
    For i = 0 To UBound(rr)
        xh = rr(i)
        n = n + 1
        br(n, 1) = n
        br(n, 2) = ar(xh, 2)
        br(n, 3) = ar(xh, 6)
        br(n, 4) = ar(xh, 5)
        br(n, 5) = ar(xh, 7)
        br(n, 6) = ar(xh, 9)
        br(n, 11) = k
        br(n, 12) = "冯威"
        hj = hj + ar(xh, 9)
    Next i
    Sheets("模板").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k
        .[a3].Resize(n, UBound(br, 2)) = br
        .[f246] = hj
        ws = n + 3
        If ws <= 245 Then .Rows(ws & ":245").Delete
    End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

测试表.rar (92.33 KB, 下载次数: 19)

2024-4-3 10:06 上传

点击文件名下载附件

jjmysjg

3190496160 发表于 2024-4-3 10:06

结果各表A1的姓名能随之改变吗？

yysfcq1

3190496160 发表于 2024-4-3 10:06

感谢老师的热心帮助，就是少了一个汇总表其他都非常不错。再次感谢@！

3190496160

jjmysjg 发表于 2024-4-3 10:54
结果各表A1的姓名能随之改变吗？

肯定可以，加一句代码即可
.[a1] = k & "  组装/调试完工产品登记表"

A刘志勇

你试试吧，

yysfcq1

A刘志勇 发表于 2024-4-3 16:01
你试试吧，

老师做出来的效果还是不对，用测试表做看看

leeson7502

参与一下，注意会删除无关工作表。