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