小弟向各位大哥请教：
公司有好多业务员（约100人），各业务员管理着不同的客户和供应商。相互之间最好不要看到对方客户和供应商的信息。
我们经常需要从软件里面导出一个表，里面有所有业务员的业务数据，我们经常要提醒业务员，哪些单位的采购发票未回来、哪些单位付钱了没交货，哪些单位还欠钱，所以需要把导出来的表，按业务员一个一个的选出来，表中其他数据整行留着，另存为一个表，表的文件名叫业务员姓名就可以了，再分别发给对应的人，这工作难度不高，但累死了，手都要点残了，希望大哥们帮忙设计一个VBA程序 ，助我脱苦海，谢谢~~~附件为信息，请参考。

没有示例

打开excel文件，按组合键Alt + F11 进入VBA编辑界面，
在项目侧栏右键，点击 导入文件：

以下代码，先另存为 “拆分sheet.bas”文件，

Attribute VB_Name = "按某列把Sheet拆分为多个文件"
'按照某列的选项分成多个Excel表格，总提示报错，请帮忙看一下，谢谢
'说明，A、必须保证有一个Sheet名为“数据源”！其余无问题，可以运行
'B、在运行的过程中，会删除 除“数据源”之外的所有Sheet
'A、B 由5hawn根据实际情况，作了修改。
'此程序的特点：在拆分的过程中，会保留原来的格式（字体、颜色等）
Sub CutSheetByColumn()
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String, shtName As String
    Dim columnNum As Integer, shtCount As Integer
    myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
    title = titleRange.Value
    shtName = titleRange.Areas.Parent.Worksheet.Name
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
'    For i = Sheets.Count To 1 Step -1
'        If Sheets(i).Name <> "数据源" Then
'            Sheets(i).Delete
'        End If
'    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets(shtName).UsedRange.Rows.Count
    Arr = Worksheets(shtName).Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k)
        Set conn = CreateObject("adodb.connection")
        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [" & shtName & "$] where " & title & " = '" & k(i) & "'"
        Dim Nowbook As Workbook
        Set Nowbook = Workbooks.Add
        With Nowbook
            With .Sheets(1)
                .Name = k(i)
                For num = 1 To UBound(myArray)
                    .Cells(1, num) = myArray(num, 1)
                Next num
                .Range("A2").CopyFromRecordset conn.Execute(Sql)
            End With
        End With
        ThisWorkbook.Activate
        Sheets(shtName).Activate
        Sheets(shtName).Cells.Select
        Selection.Copy
        Workbooks(Nowbook.Name).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Nowbook.SaveAs ThisWorkbook.Path & "\" & k(i)
        Nowbook.Close True
        Set Nowbook = Nothing
        shtCount = shtCount + 1
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "以[" & title & "]列拆分Sheet[" & shtName & "]，完成。共拆为[" & shtCount & "]个文件。", vbOKOnly, "提示："
End Sub

然后选中这个bas文件，导入，导入后，界面如图：

点击上面的三角按钮，运行这个宏代码（请自行解决宏代码的安全性规则）
运行后，会首先询问以哪一行作为标题行，一般来说，标题行总是第一行，当然，有时也有例外：

接着，是指定以哪一列作为关键字拆分，这里点击 [C1]格：

然后程序会自动进行拆分，等等约 1分钟（视用户数据量而定），因这个操作涉及到I/O，所以肯定会慢一些，直到出现：

此外，拆分好的文件是存在与母文件相同的路径下，所以，一般不建议母文件直接放在桌面上，否则程序运行完毕，桌面上会多出一堆文件，所以在运行这个之前，先把母文件放在一个专门的文件夹中，是一个好主意。拆分后的效果：

最后提醒一个注意事项，如果欲拆分的列不是文本型的，而是数值型，那么本程序不适用。
此问题常见于用户根据 某个代码（客户代码，身份证、电话号码）等来拆分，而用户的表中，这一列实际是数值，这样的话 ，本程序会出现错误。