基本操作科普： （1）打開宏編輯頁面 Alt+F12； （2）運行宏 F5 #復制完代碼，按下F5就等結果好了 （3）逐行運行宏代碼 F8 #調試代碼很好用 （4）中斷宏代碼 Ctrl+Break #出現無腦無限循環時候很好用 （5）在宏編輯頁面下，選中需要操作的工作薄，插入模塊后粘貼代碼 （6）錄制宏是個極好的入門神奇
一、工作表處理：
1.一鍵生成帶超鏈接的工作表目錄
點擊查看代碼
Sub ml()
Dim sht As Worksheet, i&, strShtName$
Columns(1).ClearContents
'清空A列數據
Cells(1, 1) = "目錄"
'第一個單元格寫入字符串"目錄"
i = 1
'將i的初值設置為1.
For Each sht In Worksheets
'循環當前工作簿的每個工作表
strShtName = sht.Name
If strShtName <> ActiveSheet.Name Then
'如果sht的名稱不是當前工作表的名稱則開始在當前工作表建立超鏈接
i = i + 1
'累加i
ActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", SubAddress:="'" & strShtName & "'!a1", TextToDisplay:=strShtName
'建超鏈接
End If
Next
End Sub
點擊查看代碼
Sub qxyc()
Dim sht As Worksheet
'定義變量
For Each sht In Worksheets
'循環工作簿里的每一個工作表
sht.Visible = xlSheetVisible
'將工作表的狀態設置為非隱藏
Next
End Sub
點擊查看代碼
Sub collect()
'VBA編程學習與實踐，一鍵多表數據匯總~看見星光
Dim sht As Worksheet, rng As Range, k&, trow&
Application.ScreenUpdating = False
'取消屏幕更新，加快代碼運行速度
trow = Val(InputBox("請輸入標題的行數", "提醒"))
If trow < 0 Then MsgBox "標題行數不能為負數。", 64, "警告": Exit Sub
'取得用戶輸入的標題行數，如果為負數，退出程序
Cells.ClearContents
'清空當前表數據
Cells.NumberFormat = "@"
'設置文本格式
For Each sht In Worksheets
'遍歷表格
If sht.Name <> ActiveSheet.Name Then
'如果表格名稱不等於當前表名則進行復制數據……
Set rng = sht.UsedRange
'定義rng為表格已用區域
k = k + 1
'累計K值
If k = 1 Then
'如果是首個表格，則K為1，則把標題行一起復制到匯總表
rng.Copy
[a1].PasteSpecial Paste:=xlPasteValues
Else
'否則，扣除標題行后再復制黏貼到總表，只黏貼數值
rng.Offset(trow).Copy
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
Next
[a1].Activate
'激活A1單元格
Application.ScreenUpdating = True
'恢復屏幕刷新
End Sub
'VBA根據A列數據批量建立工作表的代碼如下：
點擊查看代碼
Sub NewSht()
'ExcelHome VBA編程實踐與學習
Dim Sht As Worksheet, Rng As Range
Dim Sn, t$
Set Rng = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
'將工作表名稱所在的單元格區域賦值給變量Rng，單元格A1是標題，不讀入
On Error Resume Next
'當代碼出錯時繼續運行
For Each Sn In Rng
'遍歷Rng(工作表名稱集合）
t = Sn
'還記得這里我們為什么用這句代碼嗎？
Set Sht = Sheets(t)
'當工作簿不存在工作表Sheets(t)時，這句代碼會出錯，然后……
If Err Then
'如果代碼出錯，說明不存在工作表Sheets(t)，則新建工作表
Worksheets.Add , Sheets(Sheets.Count)
'新建一個工作表，位置放在所有已存在工作表的后面
ActiveSheet.Name = t
'新建的工作表必然是活動工作表，為之命名
Err.Clear
'清除錯誤狀態
End If
Next
Rng.Parent.Activate
'重新激活名稱數據所在的工作表
End Sub
點擊查看代碼
Sub SplitShts()
Dim d As Object, sht As Worksheet
Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
Dim rngData As Range, rngGist As Range
Dim lngTitleCount&, lngGistCol&, lngColCount&
Dim rngFormat As Range
Dim strKey As String
Set d = CreateObject("scripting.dictionary")
Set rngGist = Application.InputBox("請框選拆分依據列！只能選擇單列單元格區域！", Title:="提示", Type:=8)
'========用戶選擇的拆分依據列
lngGistCol = rngGist.Column
'========拆分依據列的列標
lngTitleCount = Val(Application.InputBox("請輸入總表標題行的行數？"))
'========用戶設置總表的標題行數
If lngTitleCount < 0 Then MsgBox "標題行數不能為負數，程序退出。": Exit Sub
Set rngData = ActiveSheet.UsedRange
'========總表的數據區域
Set rngFormat = ActiveSheet.Cells
'========總表的單元格集用於粘貼總表格式
aData = rngData.Value
lngGistCol = lngGistCol - rngData.Column + 1
'========計算依據列在數組中的位置
lngColCount = UBound(aData, 2)
'========數據源的列數
For i = lngTitleCount + 1 To UBound(aData)
If aData(i, lngGistCol) = "" Then aData(i, lngGistCol) = "單元格空白"
strKey = aData(i, lngGistCol)
'========統一轉換為字符串格式
If Not d.exists(strKey) Then
'========字典中不存在關鍵字時將行號裝入字典
d(strKey) = i
Else
d(strKey) = d(strKey) & "," & i
'========如果字段存在關鍵字則合並行號
End If
Next
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
'========刪除字典中存在的表名
If d.exists(sht.Name) Then sht.Delete
Next
Application.DisplayAlerts = True
aKeys = d.keys
'========字典的key集
Application.ScreenUpdating = False
For i = 0 To UBound(aKeys)
If aKeys(i) <> "" Then
aTemp = Split(d(aKeys(i)), ",")
'========取出item里儲存的行號
ReDim aResult(1 To UBound(aTemp) + 1, 1 To lngColCount)
'========聲明放置結果的數組aResult
k = 0
For x = 0 To UBound(aTemp)
k = k + 1
For j = 1 To lngColCount
aResult(k, j) = aData(aTemp(x), j)
Next
Next
With Worksheets.Add(, Sheets(Sheets.Count))
'========新建一個工作表
.Name = aKeys(i)
.[a1].Resize(UBound(aData), lngColCount).NumberFormat = "@"
'========設置單元格為文本格式
If lngTitleCount > 0 Then .[a1].Resize(lngTitleCount, lngColCount) = aData
'========標題行
.[a1].Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
'========數據
rngFormat.Copy
.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'========復制粘貼總表的格式
.[a1].Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
'========刪除多余的格式單元格
.[a1].Select
End With
End If
Next
rngData.Parent.Activate
'========激活總表
Application.ScreenUpdating = True
Set d = Nothing
Set rngData = Nothing
Set rngGist = Nothing
Set rngFormat = Nothing
Erase aData: Erase aResult
MsgBox "數據拆分完成！"
End Sub
點擊查看代碼
Sub Newbooks()
'EH技術論壇。VBA編程學習與實踐。看見星光
Dim sht As Worksheet, mypath$
With Application.FileDialog(msoFileDialogFolderPicker)
'選擇保存工作薄的文件路徑
.AllowMultiSelect = False
'不允許多選
If .Show Then
mypath = .SelectedItems(1)
'讀取選擇的文件路徑
Else
Exit Sub
'如果沒有選擇保存路徑，則退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
Application.DisplayAlerts = False
'取消顯示系統警告和消息，避免重名工作簿無法保存。當有重名工作簿時，會直接覆蓋保存。
Application.ScreenUpdating = False
'取消屏幕刷新
For Each sht In Worksheets
'遍歷工作表
sht.Copy
'復制工作表，工作表單純復制后，會成為活動工作薄
With ActiveWorkbook
.SaveAs mypath & sht.Name, xlWorkbookDefault
'保存活動工作薄到指定路徑下，以默認文件格式
.Close True '關閉工作薄並保存
End With
Next
MsgBox "處理完成。", , "提醒"
Application.ScreenUpdating = True '恢復屏幕刷新
Application.DisplayAlerts = True '恢復顯示系統警告和消息
End Sub
點擊查看代碼
Sub CollectSheets()
'ExcelHome VBA編程學習與實踐
Dim sht As Worksheet, rng As Range, k&, trow&,temp
Application.ScreenUpdating = False
'取消屏幕更新，加快代碼運行速度
temp = InputBox("請輸入需要合並的工作表所包含的關鍵詞：", "提醒")
If StrPtr(temp) = 0 Then Exit Sub
'如果點擊了inputbox的取消或者關閉按鈕，則退出程序
trow = Val(InputBox("請輸入標題的行數", "提醒"))
If trow < 0 Then MsgBox "標題行數不能為負數。", 64, "警告": Exit Sub
'取得用戶輸入的標題行數，如果為負數，退出程序
Cells.ClearContents
'清空當前表數據
For Each sht In Worksheets
'循環讀取表格
If sht.Name <> ActiveSheet.Name Then
'如果表格名稱不等於當前表名則……
If InStr(1, sht.Name, temp, vbTextCompare) Then
'如果表中包含關鍵詞則進行匯總動作(不區分關鍵詞字母大小寫）
Set rng = sht.UsedRange
'定義rng為表格已用區域
k = k + 1
'累計K值
If k = 1 Then
'如果是首個表格，則K為1，則把標題行一起復制到匯總表
rng.Copy
[a1].PasteSpecial Paste:=xlPasteValues
Else
'否則，扣除標題行后再復制黏貼到總表，只黏貼數值
rng.Offset(trow).Copy
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
End If
End If
End If
Next
[a1].Activate
'激活A1單元格
Application.ScreenUpdating = True
'恢復屏幕刷新
End Sub