代码片段_我最喜欢的代码片段

代码片段

I’ve been programming in VBA for a long time and also helping out here for a long time, and over the course of those years when I’ve developed or come across code that is clever and/or useful and/or uses “out of the box” type thinking I save the code snippet in a notebook application where I can readily find and use them when needed, and this article describes a few of my favorites in no particular order.

我从事VBA编程已经很长时间了，并且在这里已经提供了很长时间的帮助。在那些年中，我开发或遇到了聪明和/或有用的代码和/或使用“我认为代码片段保存在笔记本应用程序中 ，可以在需要时随时找到并使用它们，本文以不特定的顺序描述了我的一些收藏夹。

Two-Color conditional formatting based on another column

基于另一列的双色条件格式

I was helping someone with their project and one thing that they wanted to do was to highlight the cells in one of the columns based on the values in another.  Her data looked like this.

我正在帮助某人进行他们的项目，他们要做的一件事是根据另一列中的值突出显示其中一列中的单元格。 她的数据看起来像这样。

She wanted the ‘Numbers’ column to be highlighted based on the values in the ‘Count’ column. Looking at the request I said “conditional formatting, no problem”, but when I went to do it I found that it’s not possible to do conditional formatting of one column based on another. 

她希望根据“计数”列中的值突出显示“数字”列。 看着请求，我说“条件格式化，没问题”，但是当我去做时，我发现不可能对一个列进行基于另一列的条件格式化。

I thought about it a while and realized that the data was the result of a macro and did not have to respond to manual changes, so I could do something a little out of the box. What I came up with was this code which copies the ‘Count’ data to a temporary column, conditionally formats that column and then copies the resulting colors to the ‘Numbers’ column and voilà! Here’s the code I used.

我考虑了一会儿，意识到数据是宏的结果，不需要响应手动更改，因此我可以开箱即用。 我想到的是这段代码，它将“计数”数据复制到一个临时列中，有条件地格式化该列，然后将结果颜色复制到“数字”列中并贴上！ 这是我使用的代码。

Sub TwoColorCF()
Dim lngRow As Long


Application.ScreenUpdating = False
' Copy the Count data to a temporary column
Range("B2:B16").Copy Destination:=Range("D2:D16")


' Apply 2-color, Yellow to Green, conditional formatting to the copied data.
' The code for this was taken from a macro recording.
Range("D2:D16").Select
Selection.FormatConditions.AddColorScale ColorScaleType:=2
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
    xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
    .Color = 65535
    .TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
    xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
    .ThemeColor = xlThemeColorAccent6
    .TintAndShade = 0
End With


' Transfer the conditional formatting colors to the Numbers column
For lngRow = 2 To 16
    Cells(lngRow, "A").Interior.Color = Cells(lngRow, "D").DisplayFormat.Interior.Color
Next
' Delete the temporary column
Columns("D").Delete


Application.ScreenUpdating = True
End Sub 

The result was this.

结果就是这样。

Working with Absolute Addresses

使用绝对地址

When dealing with addresses in one of the Worksheet methods like SelectionChange, you need to be aware that the addresses contained in the Target are absolute addresses and look something like '$C$7'. Before I knew better and I needed to refer to a specific cell like C7, I would do something like this.

在使用工作表方法之一（例如SelectionChange）处理地址时，您需要注意，目标中包含的地址是绝对地址，并且看起来像“ $ C $ 7”。 在我变得更好之前，我需要引用像C7这样的特定单元格，我会做这样的事情。

If Replace(Target.Address, "$", "") = "C7" Then 

That works, and while everyone but me may have known about it, I "discovered" this built-in feature of Excel, and since it's faster to use what's built into Excel then your own code, I now do this.

这样行得通，尽管除了我之外的每个人都可能知道这一点，但是我“发现”了Excel的内置功能，由于使用Excel内置的功能要比使用自己的代码更快，因此，我现在就这样做。

If Target.Address(0, 0) = "C7" Then… 

The zeros are RowAbsolute and ColumnAbsolute and when 0 (or False) the dollar signs are ignored and when 1 (or True), they’re not.

零是RowAbsolute和ColumnAbsolute，当0（或False）时，美元符号将被忽略；而当数字1（或True）时，美元符号将不被忽略。

Centering Text Across Cells Without Merging Them

跨单元格居中放置文本而不合并它们

Merged cells can cause difficulties in VBA and in cases where you want to center text across two or more cells, you can do this rather than merging the cells. 

合并的单元格可能会在VBA中造成困难，并且如果您想将文本跨两个或多个单元格居中，则可以这样做而不是合并单元格。

1. Enter text in a cell like A1. (It must be the left-most cell of the desired range)
   在像A1这样的单元格中输入文本。 （它必须是所需范围的最左边的单元格）
2. Select a range like A1:B1
   选择一个范围，例如A1：B1
3. Format Cells|Alignment|Horizontal|Center Across Selection
   设置单元格的格式|对齐|水平|跨选择的中心
4. Click OK
   点击确定

In this case Range("A1") will return the text value while Range("B1") will return a blank.

在这种情况下，Range（“ A1”）将返回文本值，而Range（“ B1”）将返回空白。

Using Checkmarks without Having to Use Controls

使用复选标记而不必使用控件

Checkmarks on a sheet can be useful to indicate for example that you want to do something with an adjacent cell, or that some process is complete. Here’s an easy way to create a checkmark toggle without needing to use a Control. Set the font for the cell(s) to Wingdings 2, make its value an uppercase “P” and add this code.

工作表上的复选标记可用于例如指示您要对相邻单元格执行某项操作或某些过程已完成。 这是一种无需使用控件即可创建选中标记切换的简单方法。 将单元格的字体设置为Wingdings 2，将其值设置为大写“ P”并添加此代码。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then
    Exit Sub
End If
If Not Intersect(ActiveCell, Range("B2:B21")) Is Nothing Then
    Select Case Target
        Case ""
            Target = "P"
        Case Else
            Target = ""
     End Select
End If
End Sub 

Clear a Worksheet below its Headings

清除标题下方的工作表

Here's a simple way to clear a worksheet while retaining the sheet's headings. I use this all the time.

这是一种在保留工作表标题的同时清除工作表的简单方法。 我经常用这个。

' The '1' is the number of heading rows
Activesheet.UsedRange.Cells.Offset(1, 0).ClearContents 

You can use 'Clear' instead of 'ClearContents' if you also want to remove formatting.

如果您还想删除格式，则可以使用“清除”而不是“ ClearContents”。

Convert a Column Letter to a Number and Vice Versa

将列字母转换为数字，反之亦然

Function ColLetterToNum(ByVal sColLetter As String) As Long
' Convert a column letter to a number
     ColLetterToNum = ActiveWorkbook.Worksheets(1).Columns(sColLetter).Column
End Function 

Function ColNumToLetter(lColNum As Long) As String
' Convert a column number to a letter
    ColNumToLetter = Split(Cells(1, lColNum).Address, "$")(1)
End Function 

Detect No entry or Esc in an InputBox

在输入框中检测不到任何条目或Esc

In other words when those pesky users do the unexpected.

换句话说，当那些讨厌的用户做意外的事情时。

Dim strDesired As String

strDesired = InputBox("How many do you want?")
If StrPtr(strDesired) = 0 Then
    ' User pressed Escape, clicked 'Cancel' or didn't enter anything
    MsgBox "You didn't enter anything; quitting"
    Exit Sub
End If 

Create Unique Keys for Items in a Collection

为集合中的项目创建唯一键

Collections are useful ('Dictionaries' are better) for creating, well, collections of data and if you want to include keys with the items in the collection then those keys need to be unique. Here's a simple function for doing that and an example of how to use it.

集合对于创建数据集合很有用（“字典”更好），如果您想在集合中的项目中包含键，则这些键必须是唯一的。 这是执行此操作的简单功能，以及使用方法的示例。

Public Function UniqueKey() As String
'***************************************************************************
'Purpose: Generate a unique key. Actually there is a one in
'         10 million chance of the key *not* being unique, but the error
'         handling code in the calling Sub takes care of that.
'Inputs : None
'Outputs: The key for the Treeview
'***************************************************************************

    UniqueKey = "K" & 1 + Int(Rnd() * 10000000)

End Function 

Sub TestUniqueKeyGeneration()

Randomize

On Error GoTo ErrorRoutine
' Do something with the key. This example will of course
' never cause an error and is just here for illustration.
MsgBox UniqueKey

ErrorRoutine:

    If Err.Number = 35602 Then
        ' Duplicate key, get a different one
        Resume
    End If

End Sub 

I hope you found that one or more of the above was helpful

我希望您发现上述一项或多项对您有所帮助

If so then please click the “Thumb’s Up” button below. Doing so lets me know what is valuable for EE members and provides direction for future articles. It also provides me with positive feedback in the form of a few points. Thanks!

如果是这样，请单击下面的“ 拇指向上 ”按钮。 这样做可以让我知道对EE成员有价值的内容，并为以后的文章提供指导。 它还以几点的形式为我提供了积极的反馈。 谢谢！

翻译自: https://www.experts-exchange.com/articles/31877/My-Favorite-Code-Snippets.html

代码片段