99个Excel VBA经典函数源码大全

JohnTse VIP

已于 2024-01-18 13:45:14 修改

阅读量2.2k

点赞数 8

文章标签： excel

于 2023-09-06 10:09:27 首次发布

本文链接：https://blog.csdn.net/jjx168/article/details/132708958

版权

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 'Translate By Tmtony

此代码可帮助您一次单击输入多个列。运行此代码时，它会询问您要添加的列数，当您单击“确定”时，它会在所选单元格后添加输入的列数。如果要在所选单元格之前添加列，请将代码中的 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），但是如果您将此代码添加到QAT，则它不仅仅是键盘快捷方式。

7. 取消合并单元格

Sub UnmergeCells()
	Selection.UnMerge
End Sub 'Translate By Tmtony

此代码仅使用“主页”选项卡上的取消合并选项。使用此代码的好处是可以将其添加到 QAT 并取消合并所选内容中的所有单元格。如果要取消合并特定范围，可以通过替换单词选择在代码中定义该范围。

8. 打开计算器

Sub OpenCalculator()
	Application.ActivateMicrosoftApp Index:=0
End Sub

在Windows中，有一个特定的计算器，通过使用此宏代码，您可以直接从Excel打开该计算器。正如我所提到的，它适用于Windows，如果您在MAC版本的VBA中运行此代码，您将收到错误。

9. 添加页眉/页脚日期

Sub DateInHeader()
	With ActiveSheet.PageSetup
		.LeftHeader = ""
		.CenterHeader = "&D"
		.RightHeader = ""
		.LeftFooter = ""
		.CenterFooter = ""
		.RightFooter = ""
	End With
End Sub

此宏在运行标头时向其添加日期。它只是使用标签”

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 'Translate By Tmtony

每当我必须分析数据表时，我真的很喜欢使用此宏代码。以下是应用此代码的快速步骤。打开 VBE （ALT F11）。转到“项目资源管理器”（Ctrl R，如果隐藏）。选择您的工作簿

13. 突出显示前 10 个值

Sub TopTen()
	Selection.FormatConditions.AddTop10
	Selection.FormatConditions(Selection.FormatConditions.Count).S
	tFirstPriority
	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 'Translate By Tmtony

选择单元格区域并运行此代码。它将检查范围中的每个单元格，并突出显示您有负数的所有单元格。

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 "
			Go