Visual Basic for Applications/工作表通用实用程序
此页面的过程是为 Microsoft Excel 制作的，包括常用的工作表实用程序。
在创建工作表或引用假设存在的某个工作表之前，最好确定是否存在。此例程如果参数名已存在，则返回True。
Sub testSheetExists()
'run to test existence of a worksheet
If SheetExists("Sheet1") Then
MsgBox "Exists"
Else: MsgBox "Does not exist"
End If
End Sub
Function SheetExists(ByVal sSheetName As String) As Boolean
'Return true if sheet already exists
On Error Resume Next
'exists if its name is not the null string
SheetExists = (Sheets(sSheetName).Name <> vbNullString)
On Error GoTo 0
End Function
此例程使用指定名称添加工作表。但是，首先请确保工作表名称没有被使用；请参阅SheetExists()。
Sub testAddWorksheet()
AddWorksheet ("Sheet1")
End Sub
Function AddWorksheet(ByVal sName As String) As Boolean
'adds a Worksheet to ThisWorkbook with name sName
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sName
End With
AddWorksheet = True
End Function
有时，拥有例程将列的字母引用样式更改为数字引用样式，反之亦然，会很有用。这些过程可以做到这一点。
Sub testCellRefConversion()
'run this to test cell reference conversions
Dim nNum As Long, sLet As String
'set input values here
nNum = 839
sLet = "AFG"
MsgBox ConvColAlphaToNum(sLet)
MsgBox ConvColNumToAlpha(nNum)
End Sub
Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
'Converts an Excel column reference from alpha to numeric
'For example, "A" to 1, "AFG" to 839 etc
Dim nColNum As Long
'get the column number
nColNum = Range(sColAlpha & 1).Column
'output to function
ConvColAlphaToNum = nColNum
End Function
Function ConvColNumToAlpha(ByVal nColNum As Long) As String
'Converts an Excel column reference from numeric to alpha
'For example, 1 to "A", 839 to "AFG" etc
Dim sColAlpha As String, vA As Variant
'get the column alpha, in form $D$14
sColAlpha = Cells(1, nColNum).Address
'split the alpha reference on $
vA = Split(sColAlpha, "$")
'output second element (1) of array to function
ConvColNumToAlpha = vA(1) 'array is zero based
End Function
这些过程查找下一个空列或行。一组选择相关单元格，而另一组仅返回其位置。存在针对列和行的示例，并且在没有选择参数的情况下，假设为列 1 或行 1。
Sub testFindingNextCells()
'run this to test next-cell utilities
'Needs a few cols and rows of data in sheet1
'deselect to test
SelectNextAvailCellinCol 1
'MsgBox RowNumNextAvailCellinCol(1)
'SelectNextAvailCellinRow 6
'MsgBox ColNumNextAvailCellinRow(1)
End Sub
Function SelectNextAvailCellinCol(Optional ByVal nCol as Long = 1) As Boolean
'Selects next available blank cell
'in column nCol, when approached from sheet end
Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Select
End Function
Function RowNumNextAvailCellinCol(Optional ByVal nCol As Long = 1) As Long
'Returns next available blank cell's row number
'in column nCol, when approached from sheet end
RowNumNextAvailCellinCol = Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Row
End Function
Function SelectNextAvailCellinRow(Optional ByVal nRow as Long = 1) As Boolean
'Selects next available blank cell
'in row nRow, when approached from sheet right
Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Select
End Function
Function ColNumNextAvailCellinRow(Optional ByVal nRow As Long = 1) As Long
'Returns next available blank cell column number
'in row nRow, when approached from sheet right
ColNumNextAvailCellinRow = Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Column
End Function
此过程根据参数nOpt选择性地清除指定的工作表。编码的选项包括清除内容（即文本）、清除格式（字体和颜色）以及全部清除，这两种的组合。
Sub testClearWorksheet()
'run this to test worksheet clearing
If SheetExists("Sheet1") Then
ClearWorksheet "Sheet11", 3
Else 'do other stuff
End If
End Sub
Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
'clears worksheet contents, formats, or both
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Function
End Select
End With
oWSht.Cells(1, 1).Select
ClearWorksheet = True
End Function
Sub testClearRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
ClearRange Rng, "all"
Rng.Select
Set Rng = Nothing
End Sub
Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
'clears cell range contents, formats, or both
'sOpt options: "contents", "formats", or "all"
'sOpt is optional, default "contents".
With rRng
Select Case LCase(sOpt)
Case "contents" 'contents only
.ClearContents
Case "formats" 'formats only
.ClearFormats
Case "all" 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearRange - closing"
Exit Sub
End Select
End With
End Sub
有时，将整个列和行数据在电子表格上移动一个位置会很有用，并且无论如何，此过程可以根据需要重复多次。这些过程假设用户首先已将光标放在感兴趣的列或行中。列功能在将外部制表导入工作表时特别有用；列几乎肯定需要重新排列以匹配驻留集的列。食物数据库以其不同的格式而闻名，没有一个与食品标签上的格式相符。希望有一天，可以通过扫描图像一次性输入产品的食品数据。
Sub MoveRowDown()
'moves entire row with cursor down by one place
'works by moving next row up by one place
'includes all formats
Range(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Cut
ActiveCell.EntireRow.Insert xlShiftDown
ActiveCell.Offset(1, 0).Select
End Sub
Sub MoveRowUp()
'moves entire row with cursor up by one place
'includes all formats
If ActiveCell.Row > 1 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Cut
ActiveCell.Offset(-1, 0).Select
ActiveCell.EntireRow.Insert xlShiftDown
Else
MsgBox "Already at top"
End If
End Sub
Sub MoveColLeft()
'moves entire column with cursor left one place
'includes all formats
Dim sColAlpha As String, vA As Variant
Dim sCol As String
If ActiveCell.Column > 1 Then
'get the alpha reference for the column
sColAlpha = Cells(1, ActiveCell.Column).Address
vA = Split(sColAlpha, "$")
sCol = vA(1) 'array zero based
'then do the cut and insert
Range(sCol & ":" & sCol).Cut
ActiveCell.Offset(0, -1).Select
ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
Else
MsgBox "Already at extreme left"
End If
End Sub
Sub MoveColRight()
'moves entire column with cursor right one place
'works by moving next column left one place
'includes all formats
Dim sColAlpha As String, vA As Variant
Dim sCol As String
'get the alpha reference for the next column right
sColAlpha = Cells(1, ActiveCell.Column + 1).Address
vA = Split(sColAlpha, "$")
sCol = vA(1) 'array zero based
'then do the cut and insert to left for next col
Range(sCol & ":" & sCol).Cut
ActiveCell.Select
ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
ActiveCell.Offset(0, 1).Select
End Sub
这些过程允许删除工作表、行和列。在删除工作表之前，应首先确认其存在。
Sub testDeleteItems()
'run to test item deletion
'MsgBox DeleteRow(6, "Sheet1")
'MsgBox DeleteCol(3, "Sheet1")
MsgBox DeleteSheet("Sheet4")
End Sub
Function DeleteSheet(ByVal nSht As String) As Boolean
'Returns true if nSht deleted else false
'Check first if sheet exists before running this
'No confirmation dialog will be produced
Application.DisplayAlerts = False 'avoids confirm box
DeleteSheet = ThisWorkbook.Worksheets(nSht).Delete
Application.DisplayAlerts = True
End Function
Function DeleteRow(ByVal nRow As Long, ByVal sSht As String) As Boolean
'Returns true if nRow deleted else false
'No confirmation dialog will be produced
DeleteRow = ThisWorkbook.Worksheets(sSht).Rows(nRow).Delete
End Function
Function DeleteCol(ByVal nCol As Long, ByVal sSht As String) As Boolean
'Returns true if nCol deleted else false
'No confirmation dialog will be produced
DeleteCol = ThisWorkbook.Worksheets(sSht).Columns(nCol).Delete
End Function
{bookcat}