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