|
基本代码
这些 VBA 代码将帮助您快速执行一些您经常在电子表格中执行的基本任务
1.添加序列号
Sub AddSerialNumbers()
Dim i As Integer
On Error GoTo Last
i = InputBox("Enter Value", "Enter Serial Numbers")
For i = 1 To i
ActiveCell.Value = i
ActiveCell.Offset(1, 0).Activate
Next i
Last: Exit Sub
End Sub
此宏代码将帮助您在 Excel 工作表中自动添加序列号，如果您处理大数据，这对您很有帮助。
要使用此代码，您需要选择要从其中开始序列号的单元格，当您运行此代码时，它会显示一个消息框，您需要在其中输入序列号的最高编号，然后单击确定。一旦您单击“确定”，它就会简单地运行一个循环并将序列号列表添加到向下的单元格中。
2.插入多列
Sub InsertMultipleColumns()
Dim i As Integer
Dim j As Integer
ActiveCell.EntireColumn.Select
On Error GoTo Last
i = InputBox("Enter number of columns to insert", "Insert Columns")
For j = 1 To i
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromRightorAbove
Next j
Last: Exit Sub
End Sub
此代码可帮助您单击一次输入多个列。当您运行此代码时，它会询问您要添加的列数，当您单击确定时，它会在所选单元格之后添加输入的列数。如果要在所选单元格之前添加列，请将代码中的 xlToRight 替换为 xlToLeft。
3.插入多行
Sub InsertMultipleRows()
Dim i As Integer
Dim j As Integer
ActiveCell.EntireRow.Select
On Error GoTo Last
i = InputBox("Enter number of columns to insert", "Insert Columns")
For j = 1 To i
Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove
Next j
Last: Exit Sub
End Sub
使用此代码，您可以在工作表中输入多行。运行此代码时，您可以输入要插入的行数，并确保选择要插入新行的单元格。如果要在所选单元格之前添加行，请将代码中的 xlToDown 替换为 xlToUp。
4. 自动调整列
Sub AutoFitColumns()
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
此代码可快速自动适应工作表中的所有列。因此，当您运行此代码时，它将选择工作表中的所有单元格并立即自动调整所有列。
5. 自动调整行
Sub AutoFitRows()
Cells.Select
Cells.EntireRow.AutoFit
End Sub
您可以使用此代码自动调整工作表中的所有行。当您运行此代码时，它将选择工作表中的所有单元格并立即自动适应所有行。
6.删除文本换行
Sub RemoveTextWrap()
Range("A1").WrapText = False
End Sub
此代码将帮助您通过单击从整个工作表中删除文本换行。它将首先选择所有列，然后删除文本换行并自动适应所有行和列。您还可以使用 (Alt + H +W) 的快捷方式，但如果将此代码添加到快速访问工具栏，它比 键盘快捷方式更方便。
7. 取消合并单元格
Sub UnmergeCells()
Selection.UnMerge
End Sub
此代码仅使用 HOME 选项卡上的取消合并选项。使用此代码的好处是您可以将其添加到 QAT 并取消合并选择中的所有单元格。如果您想取消合并特定范围，您可以通过替换单词选择在代码中定义该范围。
8. 打开计算器
Sub OpenCalculator()
Application.ActivateMicrosoftApp Index:=0
End Sub
在 Windows 中，有一个特定的计算器，通过使用此宏代码，您可以直接从 Excel 打开该计算器。正如我提到的，它适用于 Windows，如果您在 VBA 的 MAC 版本中运行此代码，您将收到错误消息。
9. 添加页眉/页脚日期
Sub DateInHeader()
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&D"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub
当您运行此宏时，它会在标题中添加一个日期。它只是使用标签“&D”来添加日期。您还可以将其更改为页脚或通过将“”替换为日期标签来更改侧面。如果您想添加特定日期而不是当前日期，您可以使用代码中的日期替换“&D”标签。
10. 自定义页眉/页脚
Sub CustomHeader()
Dim myText As String
myText = InputBox("Enter your text here", "Enter Text")
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = myText
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
End Sub
运行此代码时，它会显示一个输入框，要求您输入要添加为标题的文本，输入后单击“确定”。
如果您仔细观察，您有六行不同的代码来选择页眉或页脚的位置。假设您想添加左页脚而不是中心页眉，只需将“myText”替换为该代码行，方法是从那里替换“”。
格式化代码
这些 VBA 代码将帮助您使用一些特定的标准和条件来格式化单元格和范围。
11. 突出显示选择中的重复项
Sub HighlightDuplicateValues()
Dim myRange As Range
Dim myCell As Range
Set myRange = Selection
For Each myCell In myRange
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 36
End If
Next myCell
End Sub
此宏将检查您选择的每个单元格并突出显示重复值。您还可以从代码中更改颜色。
12.突出显示活动的行和列
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strRange As String
strRange = Target.Cells.Address & "," & _
Target.Cells.EntireColumn.Address & "," & _
Target.Cells.EntireRow.Address
Range(strRange).Select
End Sub
每当我必须分析数据表时，我真的很喜欢使用这个宏代码。以下是应用此代码的快速步骤。
-
打开 VBE (ALT + F11)。
-
转到项目资源管理器（Ctrl + R，如果隐藏）。
-
选择您的工作簿并双击要在其中激活宏的特定工作表的名称。
-
将代码粘贴到其中并从事件下拉菜单中选择“BeforeDoubleClick”。
-
关闭 VBE，您就完成了。
请记住，通过应用此宏，您将无法通过双击来编辑单元格。
13. 突出显示前 10 个值
Sub TopTen()
Selection.FormatConditions.AddTop10
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 10
.Percent = False
End With
With Selection.FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
只需选择一个范围并运行此宏，它将以绿色突出显示前 10 个值。
14. 突出显示命名范围
Sub HighlightRanges()
Dim RangeName As Name
Dim HighlightRange As Range
On Error Resume Next
For Each RangeName In ActiveWorkbook.Names
Set HighlightRange = RangeName.RefersToRange
HighlightRange.Interior.ColorIndex = 36
Next RangeName
End Sub
如果您不确定工作表中有多少个命名范围，则可以使用此代码突出显示所有这些范围。
15.突出大于值
Sub HighlightGreaterThanValues()
Dim i As Integer
i = InputBox("Enter Greater Than Value", "Enter Value")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlGreater, Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).S
tFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(31, 218, 154)
End With
End Sub
运行此代码后，它将询问您要突出显示所有更大值的值。
16.突出低于值
Sub HighlightLowerThanValues()
Dim i As Integer
i = InputBox("Enter Lower Than Value", "Enter Value")
Selection.FormatConditions.Delete
Selection.FormatConditions.Add _
Type:=xlCellValue, _
Operator:=xlLower, _
Formula1:=i
Selection.FormatConditions(Selection.FormatConditions.Count).S
tFirstPriority
With Selection.FormatConditions(1)
.Font.Color = RGB(0, 0, 0)
.Interior.Color = RGB(217, 83, 79)
End With
End Sub
运行此代码后，它会询问您要突出显示所有较低值的值。
17. 突出显示负数
Sub highlightNegativeNumbers()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsNumber(Rng) Then
If Rng.Value < 0 Then
Rng.Font.Color = -16776961
End If
End If
Next
End Sub
选择一系列单元格并运行此代码。它将检查范围中的每个单元格并突出显示您有负数的所有单元格。
18.突出显示特定文本
Sub highlightValue()
Dim myStr As String
Dim myRg As Range
Dim myTxt As String
Dim myCell As Range
Dim myChar As String
Dim I As Long
Dim J As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
myTxt = ActiveWindow.RangeSelection.AddressLocal
Else
myTxt = ActiveSheet.UsedRange.AddressLocal
End If
LInput: Set myRg = Application.InputBox _
("please select the data range:", "Selection Required", myTxt, , , , , 8)
If myRg Is Nothing Then
Exit Sub
If myRg.Areas.Count > 1 Then
MsgBox "not support multiple columns"
GoTo LInput
End If
If myRg.Columns.Count <> 2 Then
MsgBox "the selected range can only contain two columns "
GoTo LInput
End If
For I = 0 To myRg.Rows.Count - 1
myStr = myRg.Range("B1").Offset(I, 0).Value
With myRg.Range("A1").Offset(I, 0)
.Font.ColorIndex = 1
For J = 1 To Len(.Text)
Mid(.Text, J, Len(myStr)) = myStrThen
.Characters(J, Len(myStr)).Font.ColorIndex = 3
Next
End With
Next I
End Sub
假设您有一个大型数据集，并且您想要检查特定值。为此，您可以使用此代码。当你运行它时，你会得到一个输入框来输入要搜索的值。
19. 用注释突出显示单元格
Sub highlightCommentCells()
Selection.SpecialCells(xlCellTypeComments).Select
Selection.Style = "Note"
End Sub
要突出显示所有带有注释的单元格，请使用此宏。
20. 突出显示选择中的备用行
Sub highlightAlternateRows()
Dim rng As Range
For Each rng In Selection.Rows
If rng.Row Mod 2 = 1 Then
rng.Style = "20% -Accent1"
rng.Value = rng ^ (1 / 3)
Else
End If
Next rng
End Sub
通过突出显示备用行，您可以使您的数据易于阅读，为此，您可以使用下面的 VBA 代码。它只会突出显示选定范围内的每个备用行。
21. 突出显示拼写错误的单元格
Sub HighlightMisspelledCells()
Dim rng As Range
For Each rng In ActiveSheet.UsedRange
If Not Application.CheckSpelling(word:=rng.Text) Then
rng.Style = "Bad"
End If
Next rng
End Sub
如果您发现很难检查所有单元格的拼写错误，那么此代码适合您。它将检查选择中的每个单元格并突出显示拼写错误的单元格。
22. 在整个工作表中突出显示有错误的单元格
Sub highlightErrors()
Dim rng As Range
Dim i As Integer
For Each rng In ActiveSheet.UsedRange
If WorksheetFunction.IsError(rng) Then
i = i + 1
rng.Style = "bad"
End If
Next rng
MsgBox _
"There are total " & i _
& " error(s) in this worksheet."
End Sub
要突出显示和计算您有错误的所有单元格，此代码将为您提供帮助。只需运行此代码，它将返回带有错误单元格编号的消息并突出显示所有单元格。
23. 在工作表中突出显示具有特定文本的单元格
Sub highlightSpecificValues()
Dim rng As Range
Dim i As Integer
Dim c As Variant
c = InputBox("Enter Value To Highlight")
For Each rng In ActiveSheet.UsedRange
If rng = c Then
rng.Style = "Note"
i = i + 1
End If
Next rng
MsgBox "There are total " & i & " " & c & " in this worksheet."
End Sub
此代码将帮助您计算具有特定值的单元格，然后突出显示所有这些单元格。
24.突出显示所有空白单元格不可见的空间
Sub blankWithSpace()
Dim rng As Range
For Each rng In ActiveSheet.UsedRange
If rng.Value = " " Then
rng.Style = "Note"
End If
Next rng
End Sub
有时有些单元格是空白的，但它们只有一个空格，因此，很难识别它们。此代码将检查工作表中的所有单元格并突出显示所有具有单个空格的单元格。
25. 突出显示范围内的最大值
Sub highlightMaxValue()
Dim rng As Range
For Each rng In Selection
If rng = WorksheetFunction.Max(Selection) Then
rng.Style = "Good"
End If
Next rng
End Sub
它将检查所有选定的单元格并突出显示具有最大值的单元格。
26. 突出显示范围内的最小值
Sub Highlight_Min_Value()
Dim rng As Range
For Each rng In Selection
If rng = WorksheetFunction.Min(Selection) Then
rng.Style = "Good"
End If
Next rng
End Sub
它将检查所有选定的单元格并突出显示具有最小值的单元格。
27.突出独特的价值
Sub highlightUniqueValues()
Dim rng As Range
Set rng = Selection
rng.FormatConditions.Delete
Dim uv As UniqueValues
Set uv = rng.FormatConditions.AddUniqueValues
uv.DupeUnique = xlUnique
uv.Interior.Color = vbGreen
End Sub
此代码将突出显示选择中具有唯一值的所有单元格。
28.突出列中的差异
Sub columnDifference()
Range("H7:H8,I7:I8").Select
Selection.ColumnDifferences(ActiveCell).Select
Selection.Style = "Bad"
End Sub
使用此代码，您可以突出显示两列（相应的单元格）之间的差异。
29. 突出显示行中的差异
Sub rowDifference()
Range("H7:H8,I7:I8").Select
Selection.RowDifferences(ActiveCell).Select
Selection.Style = "Bad"
End Sub
通过使用此代码，您可以突出显示两行（相应单元格）之间的差异。
打印代码
这些宏代码将帮助您自动执行一些打印任务，从而进一步节省大量时间。
30. 打印评论
Sub printComments()
With ActiveSheet.PageSetup
.printComments = xlPrintSheetEnd
End With
End Sub
使用此宏激活设置以在页面末尾打印单元格注释。假设您有 10 页要打印，使用此代码后，您将获得第 11 页最后一页的所有评论。
31. 打印窄边距
Sub printNarrowMargin()
With ActiveSheet.PageSetup
.LeftMargin = Application
.InchesToPoints (0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
End With
ActiveWindow.SelectedSheets.PrintOut _
Copies:=1, _
Collate:=True, _
IgnorePrintAreas:=False
End Sub
使用此 VBA 代码以窄边距进行打印。当您运行此宏时，它会自动将边距变窄。
32. 打印选择
Sub printSelection()
Selection.PrintOut Copies:=1, Collate:=True
End Sub
此代码将帮助您打印选定的范围。您无需转到打印选项和设置打印范围。只需选择一个范围并运行此代码。
33.打印自定义页面
Sub printCustomSelection()
Dim startpage As Integer
Dim endpage As Integer
startpage = _
InputBox("Please Enter Start Page number.", "Enter Value")
If Not WorksheetFunction.IsNumber(startpage) Then
MsgBox _
"Invalid Start Page number. Please try again.", "Error"
Exit Sub
End If
endpage = _
InputBox("Please Enter End Page number.", "Enter Value")
If Not WorksheetFunction.IsNumber(endpage) Then
MsgBox _
"Invalid End Page number. Please try again.", "Error"
Exit Sub
End If
Selection.PrintOut From:=startpage, _
To:=endpage, Copies:=1, Collate:=True
End Sub
您可以使用此代码打印自定义页面范围，而不是使用打印选项中的设置。假设您要打印 5 到 10 页。您只需要运行此 VBA 代码并输入起始页和结束页。
工作表代码
这些宏代码将帮助您轻松控制和管理工作表并节省大量时间。
34.隐藏除活动工作表之外的所有内容
Sub HideWorksheet()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub
现在，假设您要隐藏工作簿中除活动工作表之外的所有工作表。此宏代码将为您执行此操作。
相关：VBA 函数列表
35.取消隐藏所有隐藏的工作表
Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub
如果您想取消隐藏以前代码隐藏的所有工作表，这里是代码。
36.删除除活动工作表之外的所有内容
Sub DeleteWorksheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
End Sub
如果要删除活动工作表以外的所有工作表，此宏对您很有用。当您运行此宏时，它会将活动工作表的名称与其他工作表进行比较，然后将其删除。
37. 立即保护所有工作表
Sub ProtectAllWorskeets()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Enter a Password.", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:=ps
Next ws
End Sub
如果您想一次性保护所有工作表，这里有一个适合您的代码。当你运行这个宏时，你会得到一个输入框来输入密码。输入密码后，单击“确定”。并确保注意CAPS。
38.调整工作表中所有图表的大小
Sub Resize_Charts()
Dim i As Integer
For i = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(i)
.Width = 300
.Height = 200
End With
Next i
End Sub
使所有图表大小相同。此宏代码将帮助您制作相同大小的所有图表。您可以通过在宏代码中更改图表来更改图表的高度和宽度。
39.插入多个工作表
Sub InsertMultipleSheets()
Dim i As Integer
i = InputBox("Enter number of sheets to insert.", _
"Enter Multiple Sheets")
Sheets.Add After:=ActiveSheet, Count:=i
End Sub
如果您想一次性在工作簿中添加多个工作表，则可以使用此代码。当你运行这个宏代码时，你会得到一个输入框来输入你想输入的总页数。
40.保护工作表
Sub ProtectWS()
ActiveSheet.Protect "mypassword", True, True
End Sub
如果你想保护你的工作表，你可以使用这个宏代码。您只需在代码中提及您的密码即可。
41. 取消保护工作表
Sub UnprotectWS()
ActiveSheet.Unprotect "mypassword"
End Sub
如果要取消保护工作表，可以使用此宏代码。您所要做的只是提及您在保护工作表时使用的密码。
42. 排序工作表
Sub SortWorksheets()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub
此代码将帮助您根据名称对工作簿中的工作表进行排序。
43.用公式保护所有细胞
Sub lockCellsWithFormulas()
With ActiveSheet
.Unprotect
.Cells.Locked = False
.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
.Protect AllowDeletingRows:=True
End With
End Sub
要通过单击保护具有公式的单元格，您可以使用此代码。
44.删除所有空白工作表
Sub deleteBlankWorksheets()
Dim Ws As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Ws In Application.Worksheets
If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
Ws.Delete
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
运行此代码，它将检查活动工作簿中的所有工作表，如果工作表为空白，则将其删除。
45. 取消隐藏所有行和列
Sub UnhideRowsColumns()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub
您可以使用此代码一次性完成此操作，而不是手动取消隐藏行和列。
46. 将每个工作表保存为单个 PDF
Sub SaveWorkshetAsPDF()
Dim ws As Worksheet
For Each Ws In Worksheets
Ws.ExportAsFixedFormat _
xlTypePDF, _
"ENTER-FOLDER-NAME-HERE" & _
Ws.Name & ".pdf"
Next Ws
End Sub
此代码将简单地将所有工作表保存在单独的 PDF 文件中。您只需要从代码中更改文件夹名称。
47.禁用分页符
Sub DisablePageBreaks()
Dim wb As Workbook
Dim wks As Worksheet
Application.ScreenUpdating = False
For Each wb In Application.Workbooks
For Each sht In wb.Worksheets
sht.DisplayPageBreaks = False
Next sht
Next wb
Application.ScreenUpdating = True
End Sub
要禁用分页符，请使用此代码。它只会从所有打开的工作簿中禁用分页符。
工作簿代码
这些代码将帮助您以简单的方式并以最小的努力执行工作簿级别的任务。
48. 创建当前工作簿的备份
Sub FileBackUp()
ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _
"" & Format(Date, "mm-dd-yy") & " " & _
ThisWorkbook.Name
End Sub
这是最有用的宏之一，可以帮助您保存当前工作簿的备份文件。
它会将备份文件保存在保存当前文件的同一目录中，并且还会在文件名中添加当前日期。
49.一次关闭所有工作簿
Sub CloseAllWorkbooks()
Dim wbs As Workbook
For Each wbs In Workbooks
wbs.Close SaveChanges:=True
Next wb
End Sub
使用此宏代码关闭所有打开的工作簿。此宏代码将首先将所有工作簿一一检查并关闭。如果任何工作表未保存，您将收到一条消息以保存它。
50.将活动工作表复制到新工作簿中
Sub CopyWorksheetToNewWorkbook()
ThisWorkbook.ActiveSheet.Copy _
Before:=Workbooks.Add.Worksheets(1)
End Sub
假设您想将活动工作表复制到新工作簿中，只需运行此宏代码，它就会为您做同样的事情。这是一个超级节省时间的方法。
51. 电子邮件中的活动工作簿
Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "Sales@FrontLinePaper.com"
.Subject = "Growth Report"
.Body = "Hello Team, Please find attached Growth Report."
.Attachments.Add ActiveWorkbook.FullName
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
使用此宏代码可以通过电子邮件快速发送您的活动工作簿。您可以更改代码中的主题、电子邮件和正文文本，如果您想直接发送此邮件，请使用“.Send”而不是“.Display”。
52. 将工作簿添加到邮件附件
Sub OpenWorkbookAsAttachment()
Application.Dialogs(xlDialogSendMail).Show
End Sub
运行此宏后，它将打开您的默认邮件客户端并附加活动工作簿作为附件。
53. 欢迎词
Sub auto_open()
MsgBox "Welcome To ExcelChamps & Thanks for downloading this file."
End Sub
您可以使用 auto_open 执行打开文件的任务，您只需将宏命名为“auto_open”。
54. 结束语
Sub auto_close()
MsgBox "Bye Bye! Don't forget to check other cool stuff on excelchamps.com "
End Sub
您可以使用 close_open 执行打开文件的任务，您只需将宏命名为“close_open”。
55. 计算打开未保存的工作簿
Sub VisibleWorkbooks()
Dim book As Workbook
Dim i As Integer
For Each book In Workbooks
If book.Saved = False Then
i = i + 1
End If
Next book
MsgBox i
End Sub
假设您有 5-10 个打开的工作簿，您可以使用此代码获取尚未保存的工作簿数量。
数据透视表代码
这些代码将帮助您快速管理数据透视表并对其进行一些更改。
56.隐藏数据透视表小计
Sub HideSubtotals()
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
If pt Is Nothing Then
MsgBox "You must place your cursor inside of a PivotTable."
Exit Sub
End If
For Each pf In pt.PivotFields
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
End Sub
如果要隐藏所有小计，只需运行此代码。首先，确保从数据透视表中选择一个单元格，然后运行此宏。
57.刷新所有数据透视表
Sub vba_referesh_all_pivots()
Dim pt As PivotTable
For Each pt In ActiveWorkbook.PivotTables
pt.RefreshTable
Next pt
End Sub
刷新所有数据透视表的超快速方法。只需运行此代码，您的工作簿中的所有数据透视表都将一次性刷新。
58. 创建数据透视表
按照此分步指南使用 VBA 创建数据透视表。
59. 自动更新数据透视表范围
Sub UpdatePivotTableRange()
Dim Data_Sheet As Worksheet
Dim Pivot_Sheet As Worksheet
Dim StartPoint As Range
Dim DataRange As Range
Dim PivotName As String
Dim NewRange As String
Dim LastCol As Long
Dim lastRow As Long
'Set Pivot Table & Source Worksheet
Set Data_Sheet = ThisWorkbook.Worksheets("PivotTableData3")
Set Pivot_Sheet = ThisWorkbook.Worksheets("Pivot3")
'Enter in Pivot Table Name
PivotName = "PivotTable2"
'Defining Staring Point & Dynamic Range
Data_Sheet.Activate
Set StartPoint = Data_Sheet.Range("A1")
LastCol = StartPoint.End(xlToRight).Column
DownCell = StartPoint.End(xlDown).Row
Set DataRange = Data_Sheet.Range(StartPoint, Cells(DownCell, LastCol))
NewRange = Data_Sheet.Name & "!" & DataRange.Address(ReferenceStyle:=xlR1C1)
'Change Pivot Table Data Source Range Address
Pivot_Sheet.PivotTables(PivotName). _
ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:=NewRange)
'Ensure Pivot Table is Refreshed
Pivot_Sheet.PivotTables(PivotName).RefreshTable
'Complete Message
Pivot_Sheet.Activate
MsgBox "Your Pivot Table is now updated."
End Sub
如果您不使用 Excel 表格，则可以使用此代码更新数据透视表范围。
60. 禁用/启用获取透视数据
Sub activateGetPivotData()
Application.GenerateGetPivotData = True
End Sub
Sub deactivateGetPivotData()
Application.GenerateGetPivotData = False
End Sub
要禁用/启用 GetPivotData 功能，您需要使用 Excel 选项。但是使用此代码，您只需单击一下即可完成。
图表代码
使用这些 VBA 代码在 Excel 中管理图表并节省大量时间。
61. 改变图表类型
Sub ChangeChartType()
ActiveChart.ChartType = xlColumnClustered
End Sub
此代码将帮助您在不使用选项卡中的图表选项的情况下转换图表类型。您所要做的只是指定要转换为哪种类型。
下面的代码会将选定的图表转换为簇状柱形图。不同类型有不同的代码，您可以从这里找到所有这些类型。
62. 将图表粘贴为图像
Sub ConvertChartToPicture()
ActiveChart.ChartArea.Copy
ActiveSheet.Range("A1").Select
ActiveSheet.Pictures.Paste.Select
End Sub
此代码将帮助您将图表转换为图像。您只需要选择图表并运行此代码。
63.添加图表标题
Sub AddChartTitle()
Dim i As Variant
i = InputBox("Please enter your chart title", "Chart Title")
On Error GoTo Last
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Text = i
Last:
Exit Sub
End Sub
首先，您需要选择图表并运行此代码。您将获得一个输入框来输入图表标题。
高级代码
一些可用于在电子表格中执行高级任务的代码。
64. 将选定范围另存为 PDF
Sub HideSubtotals()
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
If pt Is Nothing Then
MsgBox "You must place your cursor inside of a PivotTable."
Exit Sub
End If
For Each pf In pt.PivotFields
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
End Sub
如果要隐藏所有小计，只需运行此代码。首先，确保从数据透视表中选择一个单元格，然后运行此宏。
65. 创建目录
Sub TableofContent()
Dim i As Long
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Table of Content").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)
ActiveSheet.Name = "Table of Content"
For i = 1 To Sheets.Count
With ActiveSheet
.Hyperlinks.Add _
Anchor:=ActiveSheet.Cells(i, 1), _
Address:="", _
SubAddress:="'" & Sheets(i).Name & "'!A1", _
ScreenTip:=Sheets(i).Name, _
TextToDisplay:=Sheets(i).Name
End With
Next i
End Sub
假设您的工作簿中有 100 多个工作表，现在很难导航。
不要担心这个宏代码会拯救一切。当您运行此代码时，它将创建一个新工作表并创建一个工作表索引，其中包含指向它们的超链接。
66.将范围转换为图像
Sub PasteAsPicture()
Application.CutCopyMode = False
Selection.Copy
ActiveSheet.Pictures.Paste.Select
End Sub
将所选范围粘贴为图像。您只需选择范围，一旦您运行此代码，它将自动为该范围插入一张图片。
67.插入链接图片
Sub LinkedPicture()
Selection.Copy
ActiveSheet.Pictures.Paste(Link:=True).Select
End Sub
此 VBA 代码会将您选择的范围转换为链接图片，您可以在任何地方使用该图像。
68. 使用文字转语音
Sub Speak()
Selection.Speak
End Sub
只需选择一个范围并运行此代码。Excel 将逐个单元格地说出您在该范围内的所有文本。
69. 激活数据输入表
Sub DataForm()
ActiveSheet.ShowDataForm
End Sub
有一个默认的数据输入表单 ，您可以使用它来输入数据。
70. 使用目标搜索
Sub GoalSeekVBA()
Dim Target As Long
On Error GoTo Errorhandler
Target = InputBox("Enter the required value", "Enter Value")
Worksheets("Goal_Seek").Activate
With ActiveSheet.Range("C7")
.GoalSeek_ Goal:=Target, _
ChangingCell:=Range("C2")
End With
Exit Sub
Errorhandler: MsgBox ("Sorry, value is not valid.")
End Sub
Goal Seek 可以帮助您解决复杂的问题。在使用此代码之前，请从此处了解有关目标搜索的更多信息。
71. 在 Google 上搜索的 VBA 代码
Sub SearchWindow32()
Dim chromePath As String
Dim search_string As String
Dim query As String
query = InputBox("Enter here your search here", "Google Search")
search_string = query
search_string = Replace(search_string, " ", "+")
'Uncomment the following line for Windows 64 versions and comment out Windows 32 versions'
'chromePath = "C:Program FilesGoogleChromeApplicationchrome.exe"
'Uncomment the following line for Windows 32 versions and comment out Windows 64 versions
'chromePath = "C:Program Files (x86)GoogleChromeApplicationchrome.exe"
Shell (chromePath & " -url http://google.com/#q=" & search_string)
End Sub
公式代码
这些代码将帮助您计算或获得通常使用工作表函数和公式所做的结果。
72.将所有公式转换为值
Sub convertToValues()
Dim MyRange As Range
Dim MyCell As Range
Select Case _
MsgBox("You Can't Undo This Action. " _
& "Save Workbook First?", vbYesNoCancel, _
"Alert")
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set MyRange = Selection
For Each MyCell In MyRange
If MyCell.HasFormula Then
MyCell.Formula = MyCell.Value
End If
Next MyCell
End Sub
只需将公式转换为值。当您运行此宏时，它会迅速将公式更改为绝对值。
73.从选定的单元格中删除空格
Sub RemoveSpaces()
Dim myRange As Range
Dim myCell As Range
Select Case MsgBox("You Can't Undo This Action. " _
& "Save Workbook First?", _
vbYesNoCancel, "Alert")
Case Is = vbYesThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
Set myRange = Selection
For Each myCell In myRange
If Not IsEmpty(myCell) Then
myCell = Trim(myCell)
End If
Next myCell
End Sub
此列表中最有用的宏之一。它将检查您的选择，然后从中删除所有多余的空格。
74.从字符串中删除字符
Public Function removeFirstC(rng As String, cnt As Long)
removeFirstC = Right(rng, Len(rng) - cnt)
End Function
只需从文本字符串的开头删除字符。您只需要引用一个单元格或将文本插入函数和要从文本字符串中删除的字符数。
它有两个参数“rng”表示文本字符串，“cnt”表示要删除的字符数。例如：如果要删除单元格中的第一个字符，则需要在 cnt 中输入 1。
75.在Excel中添加插入度数符号
Sub degreeSymbol()
Dim rng As Range
For Each rng In Selection
rng.Select
If ActiveCell <> "" Then
If IsNumeric(ActiveCell.Value) Then
ActiveCell.Value = ActiveCell.Value & "°"
End If
End If
Next
End Sub
假设您在一列中有一个数字列表，并且您想为所有数字添加度数符号。
76. 反转文本
Public Function rvrse(ByVal cell As Range) As String
rvrse = VBA.StrReverse(cell.Value)
End Function
您所要做的只是在单元格中输入“rvrse”函数并引用您想要反转的文本所在的单元格。
77. 激活 R1C1 参考风格
Sub ActivateR1C1()
If Application.ReferenceStyle = xlA1 Then
Application.ReferenceStyle = xlR1C1
Else
Application.ReferenceStyle = xlR1C1
End If
End Sub
此宏代码将帮助您在不使用 Excel 选项的情况下激活R1C1 参考样式。
78.激活A1参考样式
Sub ActivateA1()
If Application.ReferenceStyle = xlR1C1 Then
Application.ReferenceStyle = xlA1
Else
Application.ReferenceStyle = xlA1
End If
End Sub
此宏代码将帮助您在不使用 Excel 选项的情况下激活 A1 参考样式。
79. 插入时间范围
Sub TimeStamp()
Dim i As Integer
For i = 1 To 24
ActiveCell.FormulaR1C1 = i & ":00"
ActiveCell.NumberFormat = "[$-409]h:mm AM/PM;@"
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
End Sub
使用此代码，您可以按顺序插入从 00:00 到 23:00 的时间范围。
80. 将日期转换为日
Sub date2day()
Dim tempCell As Range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Day(tempCell)
.NumberFormat = "0"
End With
End If
Next tempCell
End Sub
如果您的工作表中有日期，并且您想将所有这些日期转换为天数，那么此代码适合您。只需选择单元格范围并运行此宏。
81. 将日期转换为年份
Sub date2year()
Dim tempCell As Range
Selection.Value = Selection.Value
For Each tempCell In Selection
If IsDate(tempCell) = True Then
With tempCell
.Value = Year(tempCell)
.NumberFormat = "0"
End With
End If
Next tempCell
End Sub
此代码会将日期转换为年份。
82.从日期中删除时间
Sub removeTime()
Dim Rng As Range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = VBA.Int(Rng.Value)
End If
Next
Selection.NumberFormat = "dd-mmm-yy"
End Sub
如果您有时间了解日期并且想要删除它，那么您可以使用此代码。
83.从日期和时间中删除日期
Sub removeDate()
Dim Rng As Range
For Each Rng In Selection
If IsDate(Rng) = True Then
Rng.Value = Rng.Value - VBA.Fix(Rng.Value)
End If
NextSelection.NumberFormat = "hh:mm:ss am/pm"
End Sub
它将仅返回日期和时间值的时间。
84. 转换为大写
Sub convertUpperCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Rng)
End If
Next
End Sub
选择单元格并运行此代码。它将检查所选范围的每个单元格，然后将其转换为大写文本。
85. 转换为小写
Sub convertLowerCase()
Dim Rng As Range
For Each Rng In Selection
If Application.WorksheetFunction.IsText(Rng) Then
Rng.Value = LCase(Rng)
End If
Next
End Sub
此代码将帮助您将所选文本转换为小写文本。只需选择包含文本的单元格范围并运行此代码。如果单元格具有数字或除文本以外的任何值，则该值将保持不变。
86. 转换为正确大小写
Sub convertProperCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value = WorksheetFunction.Proper(Rng.Value)
End If
Next
End Sub
此代码会将所选文本转换为正确的大小写，其中第一个字母为大写，其余为小写。
87. 转换为句子大小写
Sub convertTextCase()
Dim Rng As Range
For Each Rng In Selection
If WorksheetFunction.IsText(Rng) Then
Rng.Value = UCase(Left(Rng, 1)) & LCase(Right(Rng, Len(Rng) - 1))
End If
Next Rng
End Sub
在文本案例中，您将第一个单词的第一个字母大写，其余所有单词都放在一个句子中，此代码将帮助您将普通文本转换为句子大小写。
88.从选择中删除一个字符
Sub removeChar()
Dim Rng As Range
Dim rc As String
rc = InputBox("Character(s) to Replace", "Enter Value")
For Each Rng In Selection
Selection.Replace What:=rc, Replacement:=""
Next
End Sub
要从选定的单元格中删除特定字符，您可以使用此代码。它将显示一个输入框以输入要删除的字符。
89. 整个工作表的字数
Sub Word_Count_Worksheet()
Dim WordCnt As Long
Dim rng As Range
Dim S As String
Dim N As Long
For Each rng In ActiveSheet.UsedRange.Cells
S = Application.WorksheetFunction.Trim(rng.Text)
N = 0
If S <> vbNullString Then
N = Len(S) - Len(Replace(S, " ", "")) + 1
End If
WordCnt = WordCnt + N
Next rng
MsgBox "There are total " _
& Format(WordCnt, "#,##0") & _
" words in the active worksheet"
End Sub
它可以帮助您计算工作表中的所有单词。
90.从数字中删除撇号
Sub removeApostrophes()
Selection.Value = Selection.Value
End Sub
如果您有数字数据，其中每个数字前都有撇号，则运行此代码将其删除。
91.从数字中删除小数
Sub removeDecimals()
Dim lnumber As Double
Dim lResult As Long
Dim rng As Range
For Each rng In Selection
rng.Value = Int(rng)
rng.NumberFormat = "0"
Next rng
End Sub
此代码将简单地帮助您从所选范围内的数字中删除所有小数。
92.将所有值乘以一个数字
Sub multiNumber()
Dim rng As Range
Dim i As Integer
i = InputBox("Enter number to multiple", "Input Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng * i
Else
End If
Next rng
End Sub
让我们有一个数字列表，并且您想将所有数字与特定数字相乘。要使用此代码：选择该单元格范围并运行此代码。它会首先询问您要与之相乘的数字，然后立即将所有数字与之相乘。
93.在所有数字中添加一个数字
Sub addNumber()
Dim rng As Range
Dim i As Integer
i = InputBox("Enter number to add", "Input Required")
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng + i
Else
End If
Next rng
End Sub
就像乘法一样，您也可以将一个数字添加到一组数字中。
94.计算平方根
Sub getSquareRoot()
Dim rng As Range
Dim i As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = Sqr(rng)
Else
End If
Next rng
End Sub
要在不应用公式的情况下计算平方根，您可以使用此代码。它只会检查所有选定的单元格并将数字转换为其平方根。
95.计算立方根
Sub getCubeRoot()
Dim rng As Range
Dimi As Integer
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = rng ^ (1 / 3)
Else
End If
Nextrng
End Sub
要在不应用公式的情况下计算立方根，您可以使用此代码。它只会检查所有选定的单元格并将数字转换为它们的立方根。
96.在一个范围内添加AZ字母
Sub addsAlphabets1()
Dim i As Integer
For i = 65 To 90
ActiveCell.Value = Chr(i)
ActiveCell.Offset(0, 1).Select
Next i
End Sub
Sub addsAlphabets2()
Dim i As Integer
For i = 97 To 122
ActiveCell.Value = Chr(i)
ActiveCell.Offset(1, 0).Select
Next i
End Sub
就像序列号一样，您也可以在工作表中插入字母。以下是您可以使用的代码。
97. 将罗马数字转换为阿拉伯数字
Sub convertToNumbers()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If Not WorksheetFunction.IsNonText(rng) Then
rng.Value = WorksheetFunction.Arabic(rng)
End If
Next rng
End Sub
有时很难将罗马数字理解为序列号。此代码将帮助您将罗马数字转换为阿拉伯数字。
98.区域中的负数变正数
Sub removeNegativeSign()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If WorksheetFunction.IsNumber(rng) Then
rng.Value = Abs(rng)
End If
Next rng
End Sub
此代码将简单地检查选择中的所有单元格并将所有负数转换为正数。只需选择一个范围并运行此代码。
99.用零替换空白单元格
Sub replaceBlankWithZero()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = "" Or rng = " " Then
rng.Value = "0"
Else
End If
Next rng
End Sub
对于有空白单元格的数据，您可以使用以下代码在所有这些单元格中添加零。在进一步的计算中更容易使用这些单元格。
100.用空白单元格替换零
Sub replaceZeroWithBlank()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = 0 Then
rng.Value = ""
Else
End If
Next rng
End Sub
对于有空白单元格的数据，您可以使用以下代码在所有这些单元格中添加零。在进一步
|
浙公网安备 33010602011771号