Visual Basic for Applications/Excel 工作表實際使用區域
- 此程式碼列表適用於 Excel。過程 GetUsedRange 在函式名中返回工作表的實際使用區域。下面還給出了一個在過程 WorkRangeInArray 中使用它的例子。它通常可以用來查詢工作表上的下一個寫入位置，但在任何情況下它都會在每次執行時返回所有單元格限制。
- 各種網際網路網站上的報告描述了內建 UsedRange 函式的問題。除了理解錯誤之外，問題型別似乎分為與滾動單元格數量有關的問題以及報告使用區域本身的錯誤。作者無法重現報告 UsedRange 的錯誤，但請求感興趣的方的輸入。遇到 UsedRange 問題的讀者可以在這頁面的“討論”選項卡中告知我。的確，刪除工作表末尾的單元格內容不會導致滾動區域的修改，並且使用 Ctrl-End 仍然會移動到刪除後的舊位置。然而，這兩件事不一定是相關的，因為即使 UsedRange 被正確報告，這種情況仍然會發生。在此期間，此程式碼模組將獲取實際使用區域。
- 過程 GetUsedRange 從所有四個方向的外邊界開始接近使用過的單元格，然後在記錄每個方向遇到的第一個填充單元格後，將整體範圍定義為適合整個內容的最小邊界矩形。它還可以同時返回行和列邊界。
- 過程 WorkRangeInArray 在一個示例中使用了 GetUsedRange，該示例將源工作表的區域載入到一個數組中進行處理，然後將其傳回目標工作表（相同或其他）的指定或預設位置。
根據“討論”中的建議，為 GetUsedRange 引數添加了描述性變數名。（2016 年 12 月 3 日）
Option Explicit
Sub TestGetUsedRange()
'assumes that there is a block of filled cells on worksheet 1
Dim rng As Range, t, wsS As Worksheet
Dim fr As Long, lr As Long, fc As Long, lc As Long
Set wsS = ThisWorkbook.Worksheets("Sheet1")
Set wsT = ThisWorkbook.Worksheets("Sheet2")
Set rng = GetUsedRange(wsS, fr, fc, lr, lc)
'count the row and cols in range
MsgBox (lr - fr + 1) & " Rows in the range"
MsgBox (lc - fc + 1) & " Columns in the range"
'get first row number and first col number in range
MsgBox fr & " is first row number in the range"
MsgBox fc & " is first col number in the range"
'get last row number and last col number in range
MsgBox lr & " is last row number in the range"
MsgBox lc & " is last col number in the range"
End Sub
Function GetUsedRange(ws As Worksheet, Optional FirstUsedRow As Long, Optional FirstUsedColumn As Long, _
Optional LastUsedRow As Long, Optional LastUsedColumn As Long) As Range
'gets an accurate used range
Dim s As String, X As Long
Dim rng As Range
Dim r1Fixed As Long, c1Fixed As Long
Dim r2Fixed As Long, c2Fixed As Long
Dim r1 As Long, c1 As Long
Dim r2 As Long, c2 As Long
Dim i As Long
Set GetUsedRange = Nothing
'Start with Excel's UsedRange function since
'any such Excel error results in wider limits
Set rng = ws.UsedRange
'get bounding cells for Excel's used range
'that is, cells(r1,c1) to cells(r2,c2)
r1 = rng.Row
r2 = rng.Rows.Count + r1 - 1
c1 = rng.Column
c2 = rng.Columns.Count + c1 - 1
'early exit for single cell or none used
If r1 = r2 And c1 = c2 Then
Set GetUsedRange = ws.Cells(r1, c1)
FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2
Exit Function
Else
'continue to find used range
End If
'save existing values
r1Fixed = r1
c1Fixed = c1
r2Fixed = r2
c2Fixed = c2
'check rows from top down for all blanks
'if found shrink rows
For i = 1 To r2Fixed - r1Fixed + 1
If Application.CountA(rng.Rows(i)) = 0 Then
'empty row -- reduce
r1 = r1 + 1
Else
'nonempty row, get out
Exit For
End If
Next
'repeat for columns from left to right
For i = 1 To c2Fixed - c1Fixed + 1
If Application.CountA(rng.Columns(i)) = 0 Then
'empty row -- reduce
c1 = c1 + 1
Else
'nonempty row, get out
Exit For
End If
Next
'reset the range
Set rng = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
'start again
r1Fixed = r1
c1Fixed = c1
r2Fixed = r2
c2Fixed = c2
'do rows from bottom up
For i = r2Fixed - r1Fixed + 1 To 1 Step -1
If Application.CountA(rng.Rows(i)) = 0 Then
r2 = r2 - 1
Else
Exit For
End If
Next
'repeat for columns from right to left
For i = c2Fixed - c1Fixed + 1 To 1 Step -1
If Application.CountA(rng.Columns(i)) = 0 Then
c2 = c2 - 1
Else
Exit For
End If
Next
'set output parameters
Set GetUsedRange = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2
End Function
Sub TestWorkRangeInArray()
'place a block of data in Sheet 1 before run
'transfers data via a work array to Sheet 2
Dim wsS As Worksheet, wsT As Worksheet
Set wsS = ThisWorkbook.Worksheets("Sheet1")
Set wsT = ThisWorkbook.Worksheets("Sheet2")
'used range of sheet 1 to sheet 2,
'to new top left start position r,c = 5,13
WorkRangeInArray wsS, wsT, 5, 13
Set wsS = Nothing
Set wsT = Nothing
End Sub
Function WorkRangeInArray(wsSrc As Worksheet, wsTarg As Worksheet, Optional PosR As Long, _
Optional PosC As Long) As Boolean
'loads target sheet range into a work array
'user should add array work to middle section, or not, if just for transfer
'writes work array onto target worksheet, or same if so specified
'optional target sheet position, defaults to same as source
Dim vArr As Variant, rngSrc As Range, rngTarg As Range
Dim fr As Long, fc As Long, lr As Long, lc As Long
Dim nRowsSrc As Long, nColsSrc As Long, nRowsTarg As Long, nColsTarg As Long
'Load target sheet range onto the work array
'gets true used range and its row/col number limits
Set rngSrc = GetUsedRange(wsSrc, fr, fc, lr, lc)
'load values into array
If rngSrc.Cells.Count = 1 Then
ReDim vArr(1 To 1, 1 To 1)
vArr(1, 1) = rngSrc.Value
Else
vArr = rngSrc
End If
'User can place array working here, if needed
'note that code below expects same array for output
'Write work array to position on the target sheet
'activate target sheet
wsTarg.Activate
'decide sheet positon for target data
If PosR > 0 And PosC > 0 Then 'use parameter position values
Set rngTarg = wsTarg.Cells(PosR, PosC)
Else
Set rngTarg = wsTarg.Cells(fr, fc) 'position same as source
End If
'extend target range to fit
Set rngTarg = rngTarg.Resize(UBound(vArr, 1), UBound(vArr, 2))
'transfer array data to target sheet
rngTarg = vArr
'Release object variables
Set rngSrc = Nothing
Set rngTarg = Nothing
Set wsSrc = Nothing
Set wsTarg = Nothing
'Transfers
WorkRangeInArray = True
End Function