Visual Basic for Applications/Excel Sheet True Used Range

Summary This code listing is for Excel. The procedure GetUsedRange returns the true used range of the Worksheet in the function name. An example is also given below of its use in the procedure WorkRangeInArray. It can typically be used to find the next writing position on a worksheet, but in any case returns all of the cell limits on each run. Reports on various internet sites describe problems with the built-in UsedRange function. The problem types, apart from errors of understanding, seem to be divided between issues concerning the number of cells scrolled and errors in reporting the used range itself. This author has been unable to reproduce errors in reporting the UsedRange but requests inputs from interested parties. Readers with a clear demonstration of the UsedRange problem might care to advise me of it in the Discussion tab of this page. It is true to say that the removal of cell content at the end of a worksheet will not result in a revised scrolled region, and the use of Ctrl-End will still travel to the old position after deletion. These two matters are not necessarily linked however, since this still happens even while the UsedRange is correctly reported. In the meantime this code module will obtain a true used range. The procedure GetUsedRange approaches the used cells from the outer limits in all four directions, and then, after noting the first filled cells that it encounters for each direction, defines the overall range as the smallest bounding rectangle that fits the whole thing. It optionally returns the row and column bounds at the same time. The procedure WorkRangeInArray makes use of GetUsedRange in an example that loads a source sheet range onto an array for work, then passes it back to a target sheet, same or other, at some specified or default position. VBA Code Listing (Modified 3 Dec 2016) Added descriptive variable names for GetUsedRange parameters in accordance with suggestion in Discussion.(3 Dec 2016) 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 position 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