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}