准提部林

Sub 拆分另存()
Dim xS As Worksheet, xA As Range, Cn&, j&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xS In Sheets
    Set xA = xS.Range(xS.[a1], xS.UsedRange).Offset(8)
    Cn = xA.Columns.Count
    For j = 5 To Cn
        If xA.Cells(1, j) <> "Batch  No" Then GoTo j01
        If xA.Cells(2, j) = "" Then GoTo j01
        xS.Copy
        With ActiveWorkbook
             xA.Columns(j).Copy .Sheets(1).[e9]
             .Sheets(1).[f9].Resize(xA.Rows.Count, Cn).ClearContents
             .SaveAs Filename:=ThisWorkbook.Path & "\" & xA.Cells(2, j) & ".xls", CreateBackup:=False
             .Close 0
        End With
j01: Next j
Next
End Sub