如何把拆分的表自动建立一个文件夹放入

87948876

每个文件夹的名称就是和文件名一样
Sub 生成明细表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Integer
With Sheets("数据源")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "数据源工作表为空！": End
    ar = .Range("a1:i" & r)
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 Trim(ar(i, 2)) <> "" Then
        Sheets("模板").Copy after:=Sheets(Sheets.Count)
        With Sheets(Sheets.Count)
            .Name = ar(i, 1) & ar(i, 3)
            .[f4] = ar(i, 2)
            .[c3] = ar(i, 3)
            .[f3] = ar(i, 6)
            .[l3] = ar(i, 5)
            .[c4] = ar(i, 7)
            .[l4] = ar(i, 4)
            .[k5] = ar(i, 9)
            If Trim(ar(i, 8)) = "是" Then
                .CheckBox1.Value = True
                .CheckBox2.Value = False
            ElseIf Trim(ar(i, 8)) = "否" Then
                .CheckBox1.Value = False
                .CheckBox2.Value = True
            End If
        End With
    End If
Next i
Application.ScreenUpdating = True
MsgBox "明细表生成完毕"
End Sub
Sub 拆分明细表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Integer
With Sheets("数据源")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "数据源工作表为空！": End
    ar = .Range("a1:i" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        mc = ar(i, 1) & ar(i, 3)
        Sheets("模板").Copy
        Set wb = ActiveWorkbook
        With wb.Worksheets(1)
            .Name = mc
            .[f4] = ar(i, 2)
            .[c3] = ar(i, 3)
            .[f3] = ar(i, 6)
            .[l3] = ar(i, 5)
            .[c4] = ar(i, 7)
            .[l4] = ar(i, 4)
            .[k5] = ar(i, 9)
            If Trim(ar(i, 8)) = "是" Then
                .CheckBox2.Value = True
                .CheckBox1.Value = False
            ElseIf Trim(ar(i, 8)) = "否" Then
                .CheckBox2.Value = False
                .CheckBox1.Value = True
            End If
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & ".xlsx"
        wb.Close
    End If
Next i
Application.ScreenUpdating = True
MsgBox "明细表拆分为完毕"
End Sub

山菊花

Sub 拆分明细表()
    Application.ScreenUpdating = False
    Dim ar As Variant
    Dim i As Integer
    With Sheets("数据源")
        r = .Cells(Rows.Count, 2).End(xlUp).Row
        If r < 2 Then MsgBox "数据源工作表为空！": End
        ar = .Range("a1:i" & r)
    End With
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            mc = ar(i, 1) & ar(i, 3)
            Sheets("模板").Copy
            Set wb = ActiveWorkbook
            With wb.Worksheets(1)
                .Name = mc
                .[f4] = ar(i, 2)
                .[c3] = ar(i, 3)
                .[f3] = ar(i, 6)
                .[l3] = ar(i, 5)
                .[c4] = ar(i, 7)
                .[l4] = ar(i, 4)
                .[k5] = ar(i, 9)
                If Trim(ar(i, 8)) = "是" Then
                    .CheckBox2.Value = True
                    .CheckBox1.Value = False
                ElseIf Trim(ar(i, 8)) = "否" Then
                    .CheckBox2.Value = False
                    .CheckBox1.Value = True
                End If
            End With
            If Dir(ThisWorkbook.Path & "\" & mc, 16) = "" Then
                MkDir ThisWorkbook.Path & "\" & mc
            End If
            wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & "\" & mc & ".xlsx"
            wb.Close
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox "明细表拆分为完毕"
End Sub