BA中有一個對象，說其強大也不十分明顯，說不強大吧，還是有點特別的作用。
本文介紹一個不十分經常使用的一個對象DataObject。
功能介紹：
簡單來說DataObject可以存儲一段指定格式的文本并保留最近操作中的文本。
對象聲明：
Dim xData As New DataObject
首先申明一個DataObject，如上代碼，新建了一個DataObject對象，xData
對象引用：
設置對象文本：xData.SetText “這是一個DataObject對象示例！”
返回對象文本：xStr=xData.GetText
如上圖所示，設置一個單元格值，然后利用DataObject對象來顯示出來。
看上去并沒有什么用，但是在過程值傳遞應用當中，和剪貼板的功能類似。
同樣，此對象還可以和剪貼板進行數據傳遞。
GetFromClipboard | 將數據從剪貼板復制到 DataObject。 |
PutInClipboard | 將數據從 DataObject 移動到剪貼板 |
總體來說，就是個中間傳遞功能。
當然了，在實際應用當中，我們通常是設置一個公共變更來傳遞值，至于DataObject對象傳遞，有什么優勢，似乎要認真理解一番。
代碼：
Private Sub ShowDataText()
Dim xData As New DataObject
xData.SetText Range("C2").Value '設置DataObject對象文本
Dim xStr As String
xStr=xData.GetText '返回DataObject對象文本
MsgBox xStr
Set xData=Nothing
End Sub歡迎關注、收藏
---END--
前面我們發布過將多個Excel工作簿中的工作表合并到一個工作表簿中，就有網友提了一個問題，如何講一個Excel工作簿中的工作表拆分成多個工作表，其實實現的方法很多，如果數據少的話，我們直接采用Excel的篩選，然后復制粘貼就可以了，如果數據比較多，或者是日常工作的話，每天這樣復制粘貼，就很麻煩~，或者我們使用透視表也可以。我們這講就來使用VBA的方法來實現，這個方法很簡單，只需要復制代碼（代碼也是小編從網上找的，然后修改了下，這樣通用性就更強了，更多精彩請關注公眾號：word_excel_ppt），運行就可以了。
1、素材文件
素材文件
我們的素材文件是以某公司為例，數據記錄了公司旗下有7家店鋪，從2016年1月1日到2018年12月31日，每天銷售的流水數據。
存放數據的工作表名稱已修改為“數據源”，工作表的第一行為標題行，一共有2195行數據。
現在我們想按照店鋪名稱，將整個工作表拆分開。
2、操作步驟
打開我們的工作表文件以后，將需要拆分的工作表名字修改成“數據源”。然后按鍵盤上面的Alt+F11，彈出VBA編輯的窗口，將代碼粘貼進代碼編輯器中（代碼見最后附件）；
代碼窗口
重要的事情重復一次，因為我們代碼里面，要拆分的工作表名稱叫"數據源"，所以你直接把你要拆分的工作表名稱修改成“數據源”才能正常運行。
3、運行程序
在VBA編輯器中，點擊示例中的綠色三角（見上圖），或者是按鍵盤上面的F5都可以。
選擇標題行
此時會讓我們選擇標題行，我們通過鼠標點擊標記標題行（第1行）就可以了；
選擇拆分字段
接下來會讓我們選擇，需要按照哪個字段拆分，我們就選擇門店名稱（B1）單元格，然后直接點確定。
搞定
這個時候程序就會自動運行，鼠標會閃動，我們需要等一下，運行的時間就和你電腦的配置以及要拆分文件的大小有關，以我們的素材為例，大概需要10秒鐘，就可以搞定，然后會彈出一個提示完成的消息框，我們點確定就可以。
運行結果
回到我們的文件里面，可以看到程序已經給我們拆分好了，是不是覺得很方便呢？
附程序代碼（程序在Win7+Excel 2016 運行可行）：
視頻演示，稍后發布在頭條專欄中
Sub 按照指定字段拆分工作表()
'本程序來源于網絡，原作者不詳，特留此句對原作者表示感謝；
'本程序中，云淡風輕微課堂(公眾號:word_excel_ppt)進行了部分修改，適用性更廣
Dim myRange As Variant
Dim myArray
Dim titleRange As Range
Dim title As String
Dim columnNum As Integer
myRange=Application.InputBox(prompt:="請用鼠標點擊標題行：", Type:=8)
myArray=WorksheetFunction.Transpose(myRange)
Set titleRange=Application.InputBox(prompt:="請用鼠標點擊要拆分的字段，必須是第一行，且為1個單元格", Type:=8)
title=titleRange.Value
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("數據源").UsedRange.Rows.Count
Arr=Worksheets("數據源").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")
Select Case Application.Version * 1 '設置連接字符串,根據版本創建連接
Case Is <=11
conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & ThisWorkbook.FullName
Case Is >=12
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
Sql="select * from [數據源$] where " & title & "='" & k(i) & "'"
Worksheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.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
Sheets(1).Select
Sheets(1).Cells.Select
Selection.Copy
Worksheets(Sheets.Count).Activate
ActiveSheet.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode=False
Next i
conn.Close
Set conn=Nothing
Application.DisplayAlerts=True
Application.ScreenUpdating=True
MsgBox " 已經拆分完成" & vbCrLf & vbCrLf & "更多內容敬請關注公眾號:word_excel_ppt", vbInformation, "云淡風輕微課堂"
End Sub
更多精彩請關注公眾號：word_excel_ppt