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
''拆分工作表 （拆分目錄寫死為 D:/xls）
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 = "D:/xls"
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