Excel的一些VBA操作代碼

Excel的一些VBA操作代碼

4 人贊了文章作為一個剛剛Excel入門宏的小新人，把在Excel裡面用過的一些簡要操作的小代碼共賞出來，也方便以後自己查找。有些是從各種論壇博客拿來改改的，如有侵權，立馬刪除。歡迎各位dalao指教……

關於怎麼使用這些代碼，在百度經驗就有很多，這裡就不贅述了。

貼幾個了鏈接，小白可以去看看：excel vba基礎使用方法（http://jingyan.baidu.com/article/148a192166158d4d70c3b154.html），傻瓜都會用Excel VBA（教你怎麼用VBA）（http://jingyan.baidu.com/article/4ae03de32663953efe9e6b47.html）。

基本操作科普：

（1）打開宏編輯頁面 Alt+F12；

（2）運行宏 F5 #複製完代碼，按下F5就等結果好了

（3）逐行運行宏代碼 F8 #調試代碼很好用

（4）中斷宏代碼 Ctrl+Break #出現無腦無限循環時候很好用

（5）在宏編輯頁面下，選中需要操作的工作薄，插入模塊後粘貼代碼

（6）錄製宏是個極好的入門神奇

ps.以下代碼加上control As IRibbonControl，生成xlam格式的文件，可以自制各種快捷鍵，還能共享給小夥伴們。有興趣的筒子們可以百度研究下。

—————————————目——————錄——————————

1、修改單元格的字體

2、修改單元格的背景色

3、修改Sheets名稱的背景色

4、顯示隱藏的Sheets

5、修改單元格格式（年月日）

6、修改單元格格式（無格式）

7、選中區域批量查找替換

8、選中區域添加Round公式

9、建立文件目錄及鏈接

10、批量修改文件名

————————以下收藏的小代碼，閑來沒事慢慢更新———————

1、選中單元格的字體=「微軟雅黑」及大小=9號

Sub FontNamenSize() With Selection.Font .Name = "微軟雅黑" 宋體/黑體/Arial等 .Size = 9 End WithEnd Sub

2、選中單元格調為無色

Sub CellsNoHighlight() With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End WithEnd Sub

3、所有Sheets的名稱調為無色

Sub AllTabUnhighlight() For i = 1 To ActiveWorkbook.Sheets.Count With ActiveWorkbook.Sheets(i).Tab .ColorIndex = xlColorIndexNone .TintAndShade = 0 End With NextEnd Sub

4、當前工作薄所有隱藏的Sheets調為顯示，並且Sheets名稱標記為黃色

Sub UnhideAllTabWithHighlight() For i = 1 To ActiveWorkbook.Sheets.Count If ActiveWorkbook.Sheets(i).Visible = False Then ActiveWorkbook.Sheets(i).Visible = True ActiveWorkbook.Sheets(i).Tab.Color = 65535 End If NextEnd Sub

5、單元格格式調為年月日，例2016/7/1

Sub Format_yyyymd()Selection.NumberFormatLocal = "yyyy/m/d"End Sub

6、單元格格式調為無格式

Sub Format_General()Selection.NumberFormatLocal = "G/通用格式"End Sub

7、可以自行選擇一次性查找替換的內容，

Sub ReplaceEngChn() Selection.Replace What:=" ", Replacement:="" 去除空格 Selection.Replace What:=" )", Replacement:="）" 英文括弧替換成中文空號 Selection.Replace What:="(", Replacement:="（" Selection.Replace What:=":", Replacement:="：" Selection.Replace What:=";", Replacement:="；" Selection.Replace What:="[", Replacement:="【" Selection.Replace What:="]", Replacement:="】" End Sub

8、對選中區域添加Round公式，選中區域需要為數字，不然添加後公式會報錯。

Sub AfterRounding()Dim Sel As Rangem = 2 默認保留2位小數，可以修改For Each Sel In Selection Sel.Activate OrigF = ActiveCell.FormulaR1C1 If Left(OrigF, 1) = "=" Then ActiveCell.FormulaR1C1 = ("=ROUND(" & Right(OrigF, Len(OrigF) - 1) & "," & m & ")") Else ActiveCell.FormulaR1C1 = ("=ROUND(" & OrigF & "," & m & ")") End IfNextEnd Sub

9、來個長點的，遍歷某文件夾下所有文件列示於Excel中，建立超鏈接。

Public t As VariantSub M_dir() 這是一個主模塊，中間調用兩人子模塊，一個遍歷指定目錄下的所有文件夾，一個遍歷文件夾下的所有EXCEL文件 Application.DisplayAlerts = False Application.ScreenUpdating = False On Error Resume Next t = InputBox("輸入需獲取的指定目錄，如C:Program Files (x86)Microsoft OfficeOffice14XLSTART") If t = "" Then End Sheets.Add.Name = "文件夾路徑" If Err.Number <> 0 Then ActiveSheet.Delete Sheets("文件夾路徑").Cells.Delete Err.Clear: On Error GoTo 0 End If Set sh = Sheets("文件夾路徑") sh.[a1] = t & "" 以查找D盤下所有EXCEL文件為例 i = 1 Do While sh.Cells(i, 1) <> "" dirdir (sh.Cells(i, 1)) i = i + 1 Loop On Error Resume Next Sheets.Add.Name = "文件" If Err.Number <> 0 Then ActiveSheet.Delete Sheets("文件").Cells.Delete Err.Clear: On Error GoTo 0 End If Set sh2 = Sheets("文件") sh2.Cells(1, 3) = "文件名稱" sh2.Cells(1, 2) = "文件子路徑" sh2.Cells(1, 1) = "文件完整路徑" For Each cel In sh.[a1].CurrentRegion Call dirf(cel.Value) Next Sheets("文件").Columns("a:a").ColumnWidth = 0 Sheets("文件").Select MsgBox "done!", , "統計完畢" t = ""End SubSub dirf(My_Path) 遍歷文件夾下的所有文件 Set sh2 = Sheets("文件") mm = sh2.[a65536].End(xlUp).Row + 1 MyFilename = Dir(My_Path & "*.*") Do While MyFilename <> "" sh2.Cells(mm, 3) = MyFilename sh2.Cells(mm, 2) = Left(Replace(My_Path, t, ""), Len(Replace(My_Path, t, ""))) sh2.Cells(mm, 1) = My_Path & MyFilename sh2.Hyperlinks.Add Anchor:=sh2.Cells(mm, 3), Address:=My_Path & MyFilename, TextToDisplay:=MyFilename mm = mm + 1 MyFilename = Dir LoopEnd SubSub dirdir(MyPath) 遍歷指定目錄下的所有文件夾 Dim MyName Set sh = Sheets("文件夾路徑") MyName = Dir(MyPath, vbDirectory) m = sh.[a65536].End(xlUp).Row + 1 Do While MyName <> "" If MyName <> "." And MyName <> ".." Then If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then sh.Cells(m, 1) = MyPath & MyName & "" m = m + 1 End If End If MyName = Dir LoopEnd Sub

10、還是一個和文件夾相關的。可以批量給同一路徑下文件夾改文件名字，大規模改名很不錯。不過Total Command也可以事項這個功能，現在用的很少了。

Dim filePath As Variant 定義filepath為變數Dim obj As Object 定義obj為變數對象Dim fld, ff, gg 定義fld,ff,gg為變數Sub getfile_org() Cells(1, 1) = "原文件名" Cells(1, 2) = "——————" Cells(1, 3) = "新文件名" Range("A2:C9999").ClearContents 清空區域A2:C9999列 On Error Resume Next Dim shell As Variant Set shell = CreateObject("Shell.Application") Set filePath = shell.BrowseForFolder(&O0, "選擇文件夾", &H1 + &H10, "") 獲取文件夾路徑地址 Set shell = Nothing If filePath Is Nothing Then 檢測是否獲得有效路徑，如取消直接跳出程序 Exit Sub Else gg = filePath.Items.Item.path End If Set obj = CreateObject("Scripting.FileSystemObject") 定義變數 Set fld = obj.getfolder(gg) 獲取路徑 For Each ff In fld.Files 遍歷文件夾里文件 m = m + 1 Cells(m + 1, 1) = ff.Name Cells(m + 1, 2) = "—→" Cells(m + 1, 3) = ff.Name NextEnd SubSub renamefile_new() On Error Resume Next If [a2] = "" Then MsgBox "請運行getfile_org": Exit Sub For Each ff In fld.Files 遍歷文件夾里的所有文件 m = m + 1 ff.Name = Cells(m + 1, 3) 將實際文件名改成目錄中C列的對應文件名 Next MsgBox "改名已完成，請檢查", vbOKOnlyEnd Sub

推薦閱讀：