excel常用代碼集合非常重要

1、批量將工作表轉(zhuǎn)換為獨(dú)立工作簿Sub Newbooks()EH技術(shù)論壇。VBA編程學(xué)習(xí)與實(shí)踐。看見(jiàn)星光Dim sht As Worksheet, strPath$With Application.FileDialog(msoFileDialogFolderPicker)選擇保存工作薄的文件路徑If .Show ThenstrPath = .SelectedItems(1)讀取選擇的文件路徑ElseExit Sub如果沒(méi)有選擇保存路徑，則退出程序End IfEnd WithIf Right(strPath, 1) Then strPath = strPath & Application.Displ

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

3、ating = True 恢復(fù)屏 幕刷新Application.DisplayAlerts = True 恢復(fù) 顯示系統(tǒng)警告 和消息MsgBox 處理完成。，提酉1End Sub一鍵將總表數(shù)據(jù)拆分為多個(gè)分表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關(guān)閉屏 幕更新Application.DisplayAle

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

5、eSheet.UsedRange總 表的 數(shù)據(jù)區(qū)域arr = Rng 數(shù)據(jù)范 圍裝入 數(shù)組arrtCol = tCol - Rng.Column + 1計(jì)算依據(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字典中不存在 關(guān)鍵詞則將 行號(hào)裝入字典Elsed(arr(i, tCol) = d(arr(i, tCol) & , & i如果存在 則合并行號(hào)，以逗 號(hào)間 隔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 里儲(chǔ)存的行 號(hào)ReDim brr(1 To UBound(r) + 1,1 To aCol)聲 明放置 結(jié) 果的數(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)新建一個(gè)工作表，位置在所有已存在sheet的后面.Name = kr(i)表格命名.a1.Resize(tRow, aCol) = arr放標(biāo)題 行.a1.Offset(tRow, 0).Resize(k, aCol) = brr放置數(shù)據(jù)區(qū)域Rng.Copy 復(fù)制粘貼總表的格式.a1.PasteSpecialPaste:=xlPasteFormats,Operation:=xlNone,SkipBlanks:=F

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

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

10、ng = sht.UsedRange 定義rng為表格已用區(qū)域 k = k + 1 累計(jì)K值 If k = 1 Then 如果是首 個(gè)表格，則K為1 ,則把標(biāo)題行一起 復(fù)制到匯總表 rng.Copy a1.PasteSpecial Paste:=xlPasteValues Else否則，扣除 標(biāo)題行后再 復(fù)制黏貼到總表，只黏 貼數(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 恢復(fù)屏幕刷新 End Sub匯總多個(gè)工作簿的數(shù)據(jù)到總表？沒(méi)問(wèn)題！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)取得用戶(hù)選擇的文件夾路徑If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithIf Right(strPath, 1) Then strPath = strPath & strKey = InputBox( 請(qǐng)輸 入需要 合并的工作名 稱(chēng)表包 含的關(guān) 鍵字：, Remind

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

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

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

16、nt + 1 標(biāo) 記一下 匯總工 作表的個(gè)數(shù)aData = rngData.Value 數(shù)據(jù)區(qū)域讀入數(shù)組 aDataIf UBound(aData, 2) UBound(aResult, 2) Then,動(dòng)態(tài)調(diào)整結(jié)果數(shù)組aResult 的最大列數(shù)，避免明細(xì)表列數(shù) 不一的情況。For j = UBound(aResult, 2) To UBound(aData, 2)將新增的標(biāo)題寫(xiě)入?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 如果 整行非空則讀入結(jié)果數(shù)組k = k + 1 累加記錄條數(shù)aResult(k, -1) = strFileName 工作簿名稱(chēng)aRes

18、ult(k, 0) = ShtData.Name 工作 表名稱(chēng)For j = 1 To UBound(aData, 2)|aResult(k, j) =， & aData(i, j)全部 轉(zhuǎn)換為文本，避免數(shù)值變形NextEnd If If k = DATA_MAXROW Then 如果數(shù)據(jù)到達(dá)結(jié)果數(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 關(guān)閉 工作簿 End WithEnd If strFileName = Dir 下一個(gè) 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常用代碼：按一列中的部門(mén)拆分成工作 簿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 第一部分，用戶(hù)選擇保存分表工作簿的路徑。With Application.FileDialog(msoFileDialogFolderPicker),選擇保存工作薄的文件路徑.AllowMultiSelect = False不允許多選If .Show Thenmypath = .Selectedltems(l)讀取選擇的文件路徑ElseExit Sub如果沒(méi)有選擇保存路徑，則退出程序End IfEnd WithIf

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

23、MsgBox 標(biāo)題行數(shù)不能為負(fù)數(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ì)算依據(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)一轉(zhuǎn)換為字符串格式If Not d.exists(Mystr) Thend(Mystr) = i 字典中不存在關(guān)鍵詞則將行號(hào)裝入字典Elsed(Mystr) = d(Mystr) & , & i如果存在則合并行號(hào)，以逗號(hào)間隔End IfNext 第三部分遍歷字典取出分表數(shù)據(jù)明細(xì)，建立不同工作簿保存數(shù)據(jù)。Application.ScreenUpdating = False關(guān) 閉屏 幕刷新Application.DisplayAlerts = False關(guān)閉 系統(tǒng)警 告信息kr = d.keys 字 典