工作簿按明细sheet的固定字段进行拆分，如何自动化实现

sunyao0819

3190496160 发表于 2023-10-12 15:18
仅供参考

这个就是我需要的结果，非常感谢！

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, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
For Each sh In ThisWorkbook.Worksheets(Array("Summary", "Contract", "Revnue"))
    d.RemoveAll
    If sh.Name = "Summary" Then
        ks = 4
        js = 17
        lh = 1
    ElseIf sh.Name = "Contract" Then
        ks = 3
        js = 9
        lh = 6
    ElseIf sh.Name = "Revnue" Then
        ks = 3
        js = 10
        lh = 8
    End If
    r = sh.Cells(sh.Rows.Count, lh).End(xlUp).Row
    ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, js))
    For i = ks To UBound(ar)
        If Trim(ar(i, lh)) <> "" Then
            d(Trim(ar(i, lh))) = ""
        End If
    Next i
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To js)
        For i = ks To UBound(ar)
            If Trim(ar(i, lh)) = k Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
        If Not dc.exists(k) Then
            sh.Copy
            With ActiveWorkbook.Worksheets(sh.Name)
                .Range(.Cells(ks, 1), .Cells(r, js)).Borders.LineStyle = 0
                .Range(.Cells(ks, 1), .Cells(r, js)) = Empty
                If n > 0 Then
                    .Cells(ks, 1).Resize(n, UBound(br, 2)) = br
                    .Cells(ks, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
                End If
            End With
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\拆分文件\" & k & ".xlsx"
            dc(k) = ""
        Else
            sh.Copy after:=Workbooks(k & ".xlsx").Worksheets(Workbooks(k & ".xlsx").Worksheets.Count)
            With Workbooks(k & ".xlsx").Worksheets(sh.Name)
                .Range(.Cells(ks, 1), .Cells(r, js)).Borders.LineStyle = 0
                .Range(.Cells(ks, 1), .Cells(r, js)) = Empty
                If n > 0 Then
                    .Cells(ks, 1).Resize(n, UBound(br, 2)) = br
                    .Cells(ks, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
                End If
            End With
        End If
    Next k
Next sh
For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then
        wb.Close True
    End If
Next wb
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

精简了代码，更高效吧
拆分.rar (36.21 KB, 下载次数: 1)

2023-10-19 12:23 上传

点击文件名下载附件

薛定谔233

3.2这个意思？参考：https://blog.csdn.net/hhhhh_51/article/details/122414404