1、批量將工作表轉換為獨立工作簿Sub Newbooks()EH技術論壇。VBA編程學習與實踐?？匆娦枪釪im sht As Worksheet, strPath$With Application.FileDialog(msoFileDialogFolderPicker)選擇保存工作薄的文件路徑If .Show ThenstrPath = .SelectedItems(1)讀取選擇的文件路徑ElseExit Sub如果沒有選擇保存路徑，則退出程序End IfEnd WithIf Right(strPath, 1) Then strPath = strPath & Application.Displ

2、ayAlerts = False取消顯示系統(tǒng)警告和消息，避免重名工作簿無法保存。當有重名工作簿時，會直接覆 蓋保存。Application.ScreenUpdating = False取消屏幕刷新For Each sht In Worksheets遍歷工作表sht.Copy復制工作表，工作表單純復制后，會成為活動工作薄With ActiveWorkbook |.SaveAs strPath & sht.Name, xlWorkbookDefault保存活動工作薄到指定路徑下，以默認文件格式.Close True 關閉工作薄并保存End WithNextApplication.ScreenUpd

3、ating = True 恢復屏 幕刷新Application.DisplayAlerts = True 恢復 顯示系統(tǒng)警告 和消息MsgBox 處理完成。，提酉1End Sub一鍵將總表數(shù)據(jù)拆分為多個分表Sub NewShts()Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x&Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&Application.ScreenUpdating = False關閉屏 幕更新Application.DisplayAle

4、rts = False關閉 警告信息提示Set d = CreateObject(scripting.dictionary)set 字典Set Rg = Application.InputBox(請框選拆分依據(jù)列！只能 選擇單 列單元格 區(qū)域！ , Title:=提示, Type:=8)用戶選擇 的拆分依據(jù)列tCol = Rg.Column取拆分依據(jù)列列標tRow = Val(Application.InputBox(請輸入總表標題 行的行 數(shù)？)用戶設置總表的標題行數(shù)If tRow = 0 Then MsgBox 你未輸入標題行行數(shù)，程序退出。:Exit SubSet Rng = Activ

5、eSheet.UsedRange總 表的 數(shù)據(jù)區(qū)域arr = Rng 數(shù)據(jù)范 圍裝入 數(shù)組arrtCol = tCol - Rng.Column + 1計算依據(jù)列在 數(shù)組中的位置aCol = UBound(arr, 2)數(shù)據(jù)源的列 數(shù)For i = tRow + 1 To UBound(arr)遍 歷數(shù)組 arrIf Not d.exists(arr(i, tCol) Thend(arr(i, tCol) = i字典中不存在 關鍵詞則將 行號裝入字典Elsed(arr(i, tCol) = d(arr(i, tCol) & , & i如果存在 則合并行號，以逗 號間 隔End IfNextFo

6、r Each sht In Worksheets遍歷一遍工作表，如果字典中存在則刪 除If d.exists(sht.Name) Then sht.DeleteNextkr = d.keys字典的 key 集For i = 0 To UBound(kr)遍歷字典 key 值If kr(i) Then 如果 key 不為空r = Split(d(kr(i), ,)取出 item 里儲存的行 號ReDim brr(1 To UBound(r) + 1,1 To aCol)聲 明放置 結 果的數(shù)組 brrk = 0For x = 0 To UBound(r) |k = k + 1累加記錄行數(shù)For

7、j = 1 To aCol循環(huán)讀取列brr(k, j) = arr(r(x), j)NextNextWith Worksheets.Add(, Sheets(Sheets.Count)新建一個工作表，位置在所有已存在sheet的后面.Name = kr(i)表格命名.a1.Resize(tRow, aCol) = arr放標題 行.a1.Offset(tRow, 0).Resize(k, aCol) = brr放置數(shù)據(jù)區(qū)域Rng.Copy 復制粘貼總表的格式.a1.PasteSpecialPaste:=xlPasteFormats,Operation:=xlNone,SkipBlanks:=F

8、alse, Transpose:=False.a1.SelectEnd WithEnd IfNextSheets(1).Activate激活第一 個表格Set d = Nothing 釋放字典Erase arr: Erase brr 釋放 數(shù)組MsgBox 數(shù)據(jù)拆分完成！Application.ScreenUpdating = True恢 復屏 幕更新Application.DisplayAlerts = True恢復警示End Sub一鍵匯總各分表數(shù)據(jù)到總表Sub collect(),VBA編程學習與實踐，一鍵多表數(shù)據(jù)匯總Dim sht As Worksheet, rng As Range,

9、 k&, trow& Application.ScreenUpdating = False 取消屏幕更新，加快代 碼運 行速度 trow = Val(InputBox( 請輸入標題 的行數(shù),提醒) If trow 0 Then MsgBox 標題行數(shù)不能 為負數(shù)。, 64, 警告：Exit Sub 取得用戶輸入的標題行數(shù)，如果為負數(shù)，退出程序 Cells.ClearContents ,清空當前表數(shù)據(jù) For Each sht In Worksheets 循環(huán)讀取表格 If sht.Name ActiveSheet.Name Then 如果表格名 稱不等于 當前表名 則進行匯總動 作 Set r

10、ng = sht.UsedRange 定義rng為表格已用區(qū)域 k = k + 1 累計K值 If k = 1 Then 如果是首 個表格，則K為1 ,則把標題行一起 復制到匯總表 rng.Copy a1.PasteSpecial Paste:=xlPasteValues Else否則，扣除 標題行后再 復制黏貼到總表，只黏 貼數(shù)值rng.Offset(trow).CopyCells(ActiveSheet.UsedRange.Rows.Count+1, 1).PasteSpecialPaste:=xlPasteValues End If End If Next a1.Activate ,激活

11、A1單元格 Application.ScreenUpdating = True 恢復屏幕刷新 End Sub匯總多個工作簿的數(shù)據(jù)到總表？沒問題！Sub CollectWorkBookDatas()Dim ShtActive As Worksheet, rngData As Range, ShtData As WorksheetDim lngHeadLine As Long, k As LongDim i As Long, j As Long, n As LongDim aData, aResultDim strPath As String, strFileName As StringDim s

12、trKey As String, lngShtCount As Long, lngTemp As LongOn Error Resume NextWith Application.FileDialog(msoFileDialogFolderPicker)取得用戶選擇的文件夾路徑If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithIf Right(strPath, 1) Then strPath = strPath & strKey = InputBox( 請輸 入需要 合并的工作名 稱表包 含的關 鍵字：, Remind

13、er)If StrPtr(strKey) = 0 Then Exit Sub如果點擊了取消或者關閉按鈕，則退出程序lngHeadLine = Val(InputBox(Pleaseinput the header line quantity,Reminder, 1) I用戶輸入標題行，默認值為1If IngHeadLine 0 Then MsgBox 請輸入標題行 的行數(shù).,64, my user: Exit SubSet ShtActive = ActiveSheetWith Application.ScreenUpdating = False.DisplayAlerts = False.A

14、skToUpdateLinks = FalseEnd WithConst DATA_MAXROW As Long = 50000 結果 數(shù)組最 大行數(shù)Const WK_SHT_NAME As Long = 2 前面兩列是工作簿和工作表名稱的標題ReDim aResult(1 To DATA_MAXROW, -1 To 1)聲明結 果數(shù)組Cells.Clear 清除原表內(nèi)容strFileName = Dir(strPath & *.xlsx*)使用Dir函數(shù)遍歷excel 文件Do While strFileName If strFileName ThisWorkbook.Name Then 避

15、免同名文件重復打 開出錯With GetObject(strPath & strFileName)以只讀形式讀取文件時，使用getobject 會比workbooks.open 稍快 For Each ShtData In .Worksheets 遍歷表If InStr(1, ShtData.Name, strKey, vbTextCompare) Then如果表中包含關鍵字則進行匯總(不區(qū)分關鍵詞字母大小寫)Set rngData = ShtData.UsedRangeIf IsEmpty(rngData) = False Then如果工作表非空lngShtCount = lngShtCou

16、nt + 1 標 記一下 匯總工 作表的個數(shù)aData = rngData.Value 數(shù)據(jù)區(qū)域讀入數(shù)組 aDataIf UBound(aData, 2) UBound(aResult, 2) Then,動態(tài)調整結果數(shù)組aResult 的最大列數(shù)，避免明細表列數(shù) 不一的情況。For j = UBound(aResult, 2) To UBound(aData, 2)將新增的標題寫入?yún)R總表For i = 1 To lngHeadLine ShtActive.Cells(i,j+WK_SHT_NAME).Value = aData(i, j)NextNextReDim Preserve aResu

17、lt(1 To DATA_MAXROW,-1 To UBound(aData, 2)End IfFor i = lngHeadLine + 1 To UBound(aData)遍歷數(shù)據(jù)區(qū)域的行|lngTemp = 0For j = 1 To UBound(aData, 2),遍歷列If Len(aData(i, j)= 0 Then lngTemp =lngTemp + 1判斷是否為空值NextIf lngTemp UBound(aData, 2) Then 如果 整行非空則讀入結果數(shù)組k = k + 1 累加記錄條數(shù)aResult(k, -1) = strFileName 工作簿名稱aRes

18、ult(k, 0) = ShtData.Name 工作 表名稱For j = 1 To UBound(aData, 2)|aResult(k, j) =， & aData(i, j)全部 轉換為文本，避免數(shù)值變形NextEnd If If k = DATA_MAXROW Then 如果數(shù)據(jù)到達結果數(shù)組的上限，則讀入表格，騰出空 間，以便裝新的數(shù)據(jù)ShtActive.Range(a1).Offset(lngHeadLine+n).Resize(k, UBound(aResult, 2) + WK_SHT_NAME) = aResult n = n + DATA_MAXROWReDim aResu

19、lt(1 To DATA_MAXROW, -1 To UBound(aResult, 2) k = 0End If Next | End IfEnd If Next .Close False 關閉 工作簿 End WithEnd If strFileName = Dir 下一個 excel 文 件 LoopShtActive.Range(a1:b1) = Array(File name, Sheet name) If k 0 ThenShtActive.Range(a1).Offset(lngHeadLine + n).Resize(k, UBound(aResult, 2) + WK_SHT

20、_NAME) = aResultMsgBox Summary done, total combined: & lngShtCount & sheets, ,Thank youEnd IfWith Application.ScreenUpdating = True .DisplayAlerts = True .AskToUpdateLinks = True End With End SubVBA常用代碼：按一列中的部門拆分成工作 簿Sub NewWorkBooks()Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&, Mystr$Dim Rng A

21、s Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$Dim Cll As Range, sht As Worksheet 第一部分，用戶選擇保存分表工作簿的路徑。With Application.FileDialog(msoFileDialogFolderPicker),選擇保存工作薄的文件路徑.AllowMultiSelect = False不允許多選If .Show Thenmypath = .Selectedltems(l)讀取選擇的文件路徑ElseExit Sub如果沒有選擇保存路徑，則退出程序End IfEnd WithIf

22、Right(mypath, 1) Then mypath = mypath & 第二部分遍歷總表數(shù)據(jù)，通過字典將指定字段的不同明細行過濾保存Set d = CreateObject(scripting.dictionary)set 字 典Set Rg = Application.InputBox(請框選拆分依據(jù)列！只能選擇單列 單元格區(qū)域！, Title:= 提 示, Type:=8)用戶選擇的拆分依據(jù)列tCol = Rg.Column 取拆分依據(jù)列列標tRow = Val(Application.InputBox(請輸入總表標題行的行數(shù)？)用戶設置總表的標題行數(shù)If tRow 0 Then

23、MsgBox 標題行數(shù)不能為負數(shù)，程序退出。：Exit SubSet Rng = ActiveSheet.UsedRange總 表的數(shù) 據(jù)區(qū)域Set Cll = ActiveSheet.Cells用于在分表粘貼和總表同樣行高列寬的數(shù)據(jù)格式arr = Rng 數(shù)據(jù)范圍裝入數(shù)組arr tCol = tCol - Rng.Column + 1計算依據(jù)列在數(shù)組中的位置aCol = UBound(arr, 2)數(shù)據(jù)源的列數(shù)For i = tRow + 1 To UBound(arr)遍 歷數(shù)組 arrIf arr(i, tCol) = Then arr(i, tCol)=單元格空白”Mystr = arr(i, tCol)統(tǒng)一轉換為字符串格式If Not d.exists(Mystr) Thend(Mystr) = i 字典中不存在關鍵詞則將行號裝入字典Elsed(Mystr) = d(Mystr) & , & i如果存在則合并行號，以逗號間隔End IfNext 第三部分遍歷字典取出分表數(shù)據(jù)明細，建立不同工作簿保存數(shù)據(jù)。Application.ScreenUpdating = False關 閉屏 幕刷新Application.DisplayAlerts = False關閉 系統(tǒng)警 告信息kr = d.keys 字 典