excel将一个工作表根据条件拆分成多个工作簿

Function FilePicker() As String
 
'新建一个对话框对象
'MsoFileDialogType 可为以下 MsoFileDialogType 常量之一。
'msoFileDialogFilePicker  允许用户选择文件。
'msoFileDialogFolderPicker  允许用户选择一个文件夹
'msoFileDialogOpen  允许用户打开文件
'msoFileDialogSaveAs
 
Set FileDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
 
'配置对话框
With FileDialogObject
 
    .title = "请选择文件"
 
    .InitialFileName = "D:\"
 
    .AllowMultiSelect = False
    
 
End With
 
'显示对话框
FileDialogObject.Show
 
'获取选择对话框选择的文件
Set paths = FileDialogObject.SelectedItems
 
FilePicker = paths(1)
 
End Function
 
 
'拆分工作表 （选择拆分保存目录）
Sub CFGZB()
  Dim myRange As Variant
  Dim myArray
  Dim titleRange As Range
  Dim title As String
  Dim columnNum As Integer
  Dim sheetName As String
  Dim savePath As String
  Dim fieldTypeName As String
  
  
  sheetName = "Sheet1"
  
  savePath = FilePicker()
 
  If Len(savePath) = 0 Then
    savePath = "D:/"
  End If
  
  myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
  myArray = WorksheetFunction.Transpose(myRange)
 
  Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
 
  title = titleRange.Value
  columnNum = titleRange.Column
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Dim i&, Myr&, Arr, num&
  Dim d, k, fileName
 
  For i = Sheets.Count To 1 Step -1
    If Sheets(i).name <> sheetName Then
      Sheets(i).Delete
    End If
  Next i
 
  Set d = CreateObject("Scripting.Dictionary")
  Myr = Worksheets(sheetName).UsedRange.Rows.Count
  Arr = Worksheets(sheetName).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
    fieldTypeName = TypeName(k(i))
    fileName = k(i)
    If fieldTypeName = "String" Then
        Sql = "select * from [" & sheetName & "$] where " & title & " = '" & k(i) & "'"
    ElseIf fieldTypeName = "Date" Then
        Sql = "select * from [" & sheetName & "$] where " & title & " = #" & k(i) & "# "
        fileName = Replace(fileName, "/", "-")
        fileName = Replace(fileName, "\", "-")
    Else
        Sql = "select * from [" & sheetName & "$] where " & title & " = " & k(i)
    End If
    
    'MsgBox (Sql)
 
    Dim Nowbook As Workbook
    Set Nowbook = Workbooks.Add
    With Nowbook
      With .Sheets(1)
        .name = fileName
        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(1).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 savePath & "\" & fileName
    Nowbook.Close True
    Set Nowbook = Nothing
  Next i
 
  conn.Close
  Set conn = Nothing
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub