Wikibooks

Visual Basic for Applications/Excel Sheet True Used Range

< Visual Basic for Applications

Summary

edit
  • 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)

edit

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 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
Retrieved from "https://en.wikibooks.org/w/index.php?title=Visual_Basic_for_Applications/Excel_Sheet_True_Used_Range&oldid=3679360"