Excel技能樹系列10：拿來就用的巨集程式碼17條

阿新 • • 發佈：2020-10-12

這裡有一部分拿來就用的巨集程式碼，可以先觀看目錄看看是否有需要的。

取消隱藏所有的行和列

對所有合併單元格取消合併

以當前時間為名字儲存工作簿

將每張工作表單獨儲存為一個PDF檔案

將工作簿儲存為一個PDF檔案

保護所有帶公式的單元格

給選定區域交替高亮顯示，增加可讀性

高亮顯示所有帶評論的單元格

在選定區域內高亮顯示所有的空單元格

重新調整所有的圖表為同樣大小

給當前工作簿建立備份

一次性關掉所有開啟的工作簿

將選中區域儲存為PDF檔案

刪除選中單元格區域的空格字元

將選定區域內的空白單元格以0填充

合併多個工作表

合併多個Excel檔案

對於Excel來說，只需要按住Alt + F11就可以開啟巨集編輯器，然後點選插入->模組選單，將程式碼複製進去，適當修改就可以使用了。對於WPS表格需要升級為專業版本，並且安裝VBA支援才可以執行巨集程式碼。

'取消隱藏所有的行和列
SubUnhideRowsColumns()
Columns.EntireColumn.Hidden=False
Rows.EntireRow.Hidden=False
EndSub

'對所有合併單元格取消合併
SubUnmergeAllCells()
ActiveSheet.Cells.UnMerge
EndSub

'以當前時間為名儲存Excel檔案
SubSaveWorkbookWithTimeStamp()
DimtimestampAsString
timestamp=Format(Date,"dd-mm-yyyy")&"_"&Format(Time,"hh-ss")
ThisWorkbook.SaveAs"目錄絕對路徑"&timestamp
EndSub

'將每張工作表單獨儲存為一個PDF檔案
SubSaveWorkshetAsPDF()
DimwsAsWorksheet
ForEachwsInWorksheets
ws.ExportAsFixedFormatxlTypePDF,"目錄絕對路徑"&ws.Name&".pdf"
Nextws
EndSub

'將動作不儲存為一個PDF檔案
SubSaveWorkshetAsPDF()
ThisWorkbook.ExportAsFixedFormatxlTypePDF,"目錄絕對路徑"&ThisWorkbook.Name&".pdf"
EndSub

'保護所有帶公式的單元格
SubLockCellsWithFormulas()
WithActiveSheet
.Unprotect
.Cells.Locked=False
.Cells.SpecialCells(xlCellTypeFormulas).Locked=True
.ProtectAllowDeletingRows:=True
EndWith
EndSub

'在選中區域的每一行下面插入一個空行
SubInsertAlternateRows()
DimrngAsRange
DimCountRowAsInteger
DimiAsInteger
Setrng=Selection
CountRow=rng.EntireRow.Count
Fori=1ToCountRow
ActiveCell.EntireRow.Insert
ActiveCell.Offset(2,0).Select
Nexti
EndSub

'給選定區域高亮交替顯示，增加表格可讀性
SubHighlightAlternateRows()
DimMyrangeAsRange
DimMyrowAsRange
SetMyrange=Selection
ForEachMyrowInMyrange.Rows
IfMyrow.RowMod2=1Then
Myrow.Interior.Color=vbCyan
EndIf
NextMyrow
EndSub

'高亮顯示所有帶評論的單元格
SubHighlightCellsWithComments()
ActiveSheet.Cells.SpecialCells(xlCellTypeComments).Interior.Color=vbBlue
EndSub

'高亮顯示選定區域內所有的空單元格
SubHighlightBlankCells()
DimDatasetasRange
SetDataset=Selection
Dataset.SpecialCells(xlCellTypeBlanks).Interior.Color=vbRed
EndSub

'將所有的圖表調整為同樣大小
SubResize_Charts()
DimiAsInteger
Fori=1ToActiveSheet.ChartObjects.Count
WithActiveSheet.ChartObjects(i)
.Width=300
.Height=200
EndWith
Nexti
EndSub

'按照時間建立當前工作簿的備份
SubFileBackUp()
ThisWorkbook.SaveCopyAsFilename:=ThisWorkbook.Path&_
""&Format(Date,"mm-dd-yy")&""&_
ThisWorkbook.name
EndSub

'刪除選中單元格區域的空格字元
SubRemoveSpaces()
DimmyRangeAsRange
DimmyCellAsRange
SelectCaseMsgBox("YouCan'tUndoThisAction."_
&"SaveWorkbookFirst?",_
vbYesNoCancel,"Alert")
CaseIs=vbYesThisWorkbook.Save
CaseIs=vbCancel
ExitSub
EndSelect
SetmyRange=Selection
ForEachmyCellInmyRange
IfNotIsEmpty(myCell)Then
myCell=Trim(myCell)
EndIf
NextmyCell
EndSub

'將選定單元格區域內的空單元格以0填充
SubreplaceBlankWithZero()
DimrngAsRange
Selection.Value=Selection.Value
ForEachrngInSelection
Ifrng=""Orrng=""Then
rng.Value="0"
Else
EndIf
Nextrng
EndSub

'合併多個工作表，這些工作表要有同樣的表頭，並且沒有合併單元格
OptionExplicit
Subhebing()
'把各班成績表中的記錄合併到"成績表"工作表中
DimshtAsWorksheet
Setsht=Worksheets("成績表")'你要合併在哪張工作表，就把哪張工作表的名字輸入進去即可
sht.Rows("2:65536").Clear'刪除成績表中的原有記錄
DimwtAsWorksheet,xrowAsInteger,rngAsRange
ForEachwtInWorksheets'迴圈處理工作簿中的每張工作表
Ifwt.Name<>"成績表"Then'你需要合併資料的那張工作表的名字
Setrng=sht.Range("A1048576").End(xlUp).Offset(1,0)
xrow=wt.Range("A1").CurrentRegion.Rows.Count-1
wt.Range("A2").Resize(xrow,7).Copyrng'數字7對應你要合併的工作表有多少列就寫幾，在本例中是7.
EndIf
Next
EndSub

合併多個工作表

'合併多個Excel檔案，這些工作表要有同樣的表頭，並且沒有合併單元格
OptionExplicit
SubHzWb()
DimbtAsRange,rAsLong,cAsLong
r=1'1是表頭的行數
c=7'7是表頭的列數
DimwtAsWorksheet
Setwt=ThisWorkbook.Worksheets(1)'將彙總表賦給變數wt
wt.Rows(r+1&":1048576").ClearContents'清除彙總表中原表資料,只保留表頭
Application.ScreenUpdating=False
DimFileNameAsString,shtAsWorksheet,wbAsWorkbook
DimErowAsLong,fnAsString,arrAsVariant
FileName=Dir(ThisWorkbook.Path&"\*.xlsx")
DoWhileFileName<>""
IfFileName<>ThisWorkbook.NameThen'判斷檔案是否是彙總資料的工作簿
Erow=wt.Range("A1").CurrentRegion.Rows.Count+1'取得彙總表中第一條空行行號
fn=ThisWorkbook.Path&"\"&FileName'將第1個要彙總的工作簿名稱賦給變數fn
Setwb=GetObject(fn)'將變數fn代表的工作簿物件賦給變數wb
Setsht=wb.Worksheets(1)'將要彙總的工作表賦給變數sht
'將工作表中要彙總的記錄儲存在陣列arr裡
arr=sht.Range(sht.Cells(r+1,"A"),sht.Cells(1048576,"B").End(xlUp).Offset(0,5))
'將陣列arr中的資料寫入工作表
wt.Cells(Erow,"A").Resize(UBound(arr,1),UBound(arr,2))=arr
wb.CloseFalse
EndIf
FileName=Dir'用Dir函式取得其他檔名，並賦給變數
Loop
Application.ScreenUpdating=True
EndSub