Fastest ValueRange function

Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type

Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private Const TWO_32 = 4294967296#
Dim StartTime As Double
Const ITERATION_MAX = 50000


Private Function LI2Double(LI As LARGE_INTEGER) As Double
  Dim Low As Double
  Low = LI.lowpart
  If Low < 0 Then
    Low = Low + TWO_32
  End If
  LI2Double = LI.highpart * TWO_32 + Low
End Function
Private Sub StartTimer()
  Dim PerfFrequency As LARGE_INTEGER
  QueryPerformanceCounter PerfFrequency
  StartTime = LI2Double(PerfFrequency)
End Sub
Private Function GetTimer() As Double
  Dim PerfFrequency As LARGE_INTEGER, Freq As LARGE_INTEGER
  QueryPerformanceCounter PerfFrequency
  QueryPerformanceFrequency Freq
  GetTimer = 1000# * (LI2Double(PerfFrequency) - StartTime) / LI2Double(Freq)
End Function





Function RealUsedRange_Sancarn1(sht As Worksheet) As Range
  'Get used range
  Dim ur As Range
  Set ur = sht.UsedRange

  'If used range is 1x1 then result is 1x1
  If ur.Rows.Count = 1 And ur.Columns.Count = 1 Then
    Set RealUsedRange_Sancarn1 = ur
    Exit Function
  End If

  'Find all non-empty cells
  Dim x, y As Range
  On Error Resume Next
  Set x = ur.SpecialCells(xlCellTypeConstants)
  Set y = ur.SpecialCells(xlCellTypeFormulas)
  If Not (y Is Nothing Or x Is Nothing) Then
    Set x = Application.Union(x, y)
  ElseIf x Is Nothing Then
    If y Is Nothing Then
      ValueBoundingBox = Nothing
      Exit Function
    Else
      Set x = y
    End If
  End If

  'Loop over all areas
  Dim area As Range, colMin, colMax, rowMin, rowMax, colArea, colAreaMax, rowArea, rowAreaMax As Long

  'Set Initial (Large) values for colMin and rowMin
  rowMin = 1048576
  colMin = 16384

  'Loop over all areas selected by special cells.
  For Each area In x.Areas
    With area
      'Calculate min and max rows/cols of area
      colArea = .Column
      colAreaMax = .Column + .Columns.Count - 1
      rowArea = .row
      rowAreaMax = .row + .Rows.Count - 1

      'Calculate min/max of range based on these values
      If rowAreaMax > rowMax Then rowMax = rowAreaMax
      If rowArea < rowMin Then rowMin = rowArea
      If colAreaMax > colMax Then colMax = colAreaMax
      If colArea < colMin Then colMin = colArea
    End With
  Next

  'Return bounding box
  Set RealUsedRange_Sancarn1 = Range(sht.Cells(rowMin, colMin), sht.Cells(rowMax, colMax))
End Function

Function RealUsedRange_Sancarn2(sht As Worksheet) As Range
  'Get used range
  Dim ur As Range
  Set ur = sht.UsedRange

  'If used range is 1x1 then result is 1x1
  If ur.Rows.Count = 1 And ur.Columns.Count = 1 Then
    Set RealUsedRange_Sancarn2 = ur
    Exit Function
  End If

  'Find via array
  'Get array of all values:
  On Error GoTo URValueError
    Dim v As Variant
    v = ur.Value
  On Error GoTo 0

  'Offsets if they exist
  Dim offR, offC As Long
  With ur
    offR = .row - 1
    offC = .Column - 1
  End With

  'Define required values
  Dim colMin, colMax, rowMin, rowMax, row, col As Long

  'Find min row:
  For row = LBound(v, 1) To UBound(v, 1)
    For col = LBound(v, 2) To UBound(v, 2)
      If Not IsEmpty(v(row, col)) Then
        rowMin = row
        GoTo NextNum
      End If
    Next
  Next
NextNum:
  'Find max row
  For row = UBound(v, 1) To LBound(v, 1) Step -1
    For col = LBound(v, 2) To UBound(v, 2)
      If Not IsEmpty(v(row, col)) Then
        rowMax = row
        GoTo NextNum2
      End If
    Next
  Next
NextNum2:
  'Find min col:
  For col = LBound(v, 2) To UBound(v, 2)
    For row = LBound(v, 1) To UBound(v, 1)
      If Not IsEmpty(v(row, col)) Then
        colMin = col
        GoTo NextNum3
      End If
    Next

  Next
NextNum3:
  'Find max col
  For col = UBound(v, 2) To LBound(v, 2) Step -1
    For row = LBound(v, 1) To UBound(v, 1)
      If Not IsEmpty(v(row, col)) Then
        colMax = col
        GoTo NextNum4
      End If
    Next
  Next
NextNum4:
  Set RealUsedRange_Sancarn2 = Range(sht.Cells(offR + rowMin, offC + colMin), sht.Cells(offR + rowMax, offC + colMax))
  Exit Function
URValueError:
  If Err.Number = 7 Then 'Out of memory error:
    'If out of memory, fall back on VBasic2000's version. It's not optimal but it doesn't have memory issues!
    Dim firstCell, lastCell As Range
    With sht
      Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows)
      If Not firstCell Is Nothing Then
        Set lastCell = .Cells.Find("*", .Cells(1048576, 16384), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious)
        Set RealUsedRange_Sancarn2 = .Range(firstCell, lastCell)
      End If
    End With
  Else
    'Raise unhandled error
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
  End If
End Function

Function RealUsedRange_VBasic2008(objWs As Worksheet) As Range
    With objWs
      If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) Is Nothing Then
        Set RealUsedRange_VBasic2008 = .Range( _
          .Cells( _
            .Cells.Find( _
              "*", .Cells( _
                .Rows.Count, .Columns.Count _
              ) _
            ).row, .Cells.Find( _
              "*", .Cells( _
                .Rows.Count, .Columns.Count _
              ), , , 2 _
            ).Column _
          ), .Cells( _
            .Cells.Find( _
              "*", , , , 1, 2 _
            ).row, .Cells.Find( _
              "*", , , , 2, 2 _
            ).Column _
          ) _
        )
      End If
    End With
End Function

Function RealUsedRange_IAmNerd2000_1(ws As Worksheet) As Range
  Dim rng As Range
  Set rng = ws.UsedRange.Cells(1, 1)
  Set RealUsedRange_IAmNerd2000_1 = Range(rng, rng.SpecialCells(xlLastCell, xlTextValues))
End Function

Function RealUsedRange_Sancarn3(sht As Worksheet) As Range
  'Get used range
  Dim ur As Range
  Set ur = sht.UsedRange

  'If used range is 1x1 then result is 1x1
  If ur.Rows.Count = 1 And ur.Columns.Count = 1 Then
    Set RealUsedRange_Sancarn3 = ur
    Exit Function
  End If

  'Find via array
  'Get array of all values:
  On Error GoTo URValueError
    Dim v As Variant
    v = ur.Value
  On Error GoTo 0

  'Offsets if they exist
  Dim offR, offC As Long
  With ur
    offR = .row - 1
    offC = .Column - 1
  End With

  'Define required values
  Dim colMin, colMax, rowMin, rowMax, row, col As Long

  'Find min row:
  Dim ubndR, ubndC, lbndR, lbndC As Long
  lbndR = LBound(v, 1)
  lbndC = LBound(v, 2)
  ubndR = UBound(v, 1)
  ubndC = UBound(v, 2)

  For row = lbndR To ubndR
    For col = lbndC To ubndC
      If Not IsEmpty(v(row, col)) Then
        rowMin = row
        GoTo NextNum
      End If
    Next
  Next
NextNum:
  'Find max row
  For row = ubndR To lbndR Step -1
    For col = lbndC To ubndC
      If Not IsEmpty(v(row, col)) Then
        rowMax = row
        GoTo NextNum2
      End If
    Next
  Next
NextNum2:
  'Find min col:
  For col = lbndC To ubndC
    For row = lbndR To ubndR
      If Not IsEmpty(v(row, col)) Then
        colMin = col
        GoTo NextNum3
      End If
    Next

  Next
NextNum3:
  'Find max col
  For col = ubndC To lbndC Step -1
    For row = lbndR To ubndR
      If Not IsEmpty(v(row, col)) Then
        colMax = col
        GoTo NextNum4
      End If
    Next
  Next
NextNum4:
  Set RealUsedRange_Sancarn3 = Range(sht.Cells(offR + rowMin, offC + colMin), sht.Cells(offR + rowMax, offC + colMax))
  Exit Function
URValueError:
  If Err.Number = 7 Then 'Out of memory error:
    'If out of memory, fall back on VBasic2000's version. It's not optimal but it doesn't have memory issues!
    Dim firstCell, lastCell As Range
    With sht
      Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows)
      If Not firstCell Is Nothing Then
        Set lastCell = .Cells.Find("*", .Cells(1048576, 16384), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious)
        Set RealUsedRange_Sancarn3 = .Range(firstCell, lastCell)
      End If
    End With
  Else
    'Raise unhandled error
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
  End If
End Function

Function RealUsedRange_IAmNerd2000_2(sht As Worksheet) As Range
    'Get used range
  Dim ur As Range
  Set ur = sht.UsedRange

  'If used range is 1x1 then result is 1x1
  If ur.Rows.Count = 1 And ur.Columns.Count = 1 Then
    Set RealUsedRange_IAmNerd2000_2 = ur
    Exit Function
  End If

  'Find via array
  'Get array of all values:
  On Error GoTo URValueError
    Dim v As Variant
    v = ur.Value
  On Error GoTo 0

  'Offsets if they exist
  Dim offR, offC As Long
  With ur
    offR = .row - 1
    offC = .Column - 1
  End With

  'Define required values
  Dim colMin, colMax, rowMin, rowMax, row, col As Long

  'Find min row:
  Dim ubndR, ubndC, lbndR, lbndC, tmp As Long
  lbndR = LBound(v, 1)
  lbndC = LBound(v, 2)
  ubndR = UBound(v, 1)
  ubndC = UBound(v, 2)

  'Find top and bottom most rows:
  For row = lbndR To ubndR
    For col = lbndC To ubndC
      tmp = ubndR - row + 1
      If Not IsEmpty(v(tmp, col)) Then
          rowMax = tmp
      End If
      If Not IsEmpty(v(row, col)) Then
        rowMin = row
      End If
      If IsEmpty(rowMin) And IsEmpty(rowMax) Then
          GoTo NextNum
      End If
    Next
  Next
NextNum:
  'Find top and bottom most rows:
  For col = lbndC To ubndC
    For row = lbndR To ubndR
      tmp = ubndC - col + 1
      If Not IsEmpty(v(row, tmp)) Then
          colMax = tmp
      End If
      If Not IsEmpty(v(row, col)) Then
        colMin = col
      End If
      If IsEmpty(colMin) And IsEmpty(colMax) Then
          GoTo NextNum2
      End If
    Next
  Next
NextNum2:
  Set RealUsedRange_IAmNerd2000_2 = Range(sht.Cells(offR + rowMin, offC + colMin), sht.Cells(offR + rowMax, offC + colMax))
  Exit Function
URValueError:
  If Err.Number = 7 Then 'Out of memory error:
    'If out of memory, fall back on VBasic2000's version. It's not optimal but it doesn't have memory issues!
    Dim firstCell, lastCell As Range
    With sht
      Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows)
      If Not firstCell Is Nothing Then
        Set lastCell = .Cells.Find("*", .Cells(1048576, 16384), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious)
        Set RealUsedRange_IAmNerd2000_2 = .Range(firstCell, lastCell)
      End If
    End With
  Else
    'Raise unhandled error
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
  End If
End Function

Function RealUsedRange_VBasic2008_refac(sht As Worksheet) As Range
  Dim firstCell, lastCell1, lastCell2 As Range
  With sht
    'Start at first cell in sheet, go forward and find next cell (i.e. first cell of RealUsedRange)
    Set firstCell = .Cells.Find("*", .Cells(1, 1), Excel.XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows)
    If Not firstCell Is Nothing Then
        'Start at last cell in sheet, go back and find previous cell (i.e. last cell of RealUsedRange)
        Set lastCell1 = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious)
        Set lastCell2 = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows, xlPrevious)
        'Find combined range between first and last cell
        Set RealUsedRange_VBasic2008_refac = Range(firstCell, Range(lastCell1, lastCell2))
    End If
  End With
End Function

Function RealUsedRange_Tinman(ws As Worksheet) As Range
    Dim r As Long, c As Long
    Dim data As Variant

    Dim flag As Boolean
    With ws.UsedRange
        If .Count = 1 Then
            If Not (.Cells(1, 1)) Then Set RealUsedRange_Tinman = .Cells(1, 1)
            Exit Function
        End If

        data = .Value2
        For r = 1 To UBound(data)
            For c = 1 To UBound(data, 2)
                If Not IsEmpty(data(r, c)) Then
                    flag = True
                    Exit For
                End If
            Next
            If flag Then Exit For
        Next
        'There is no data
        If Not flag Then
            Set RealUsedRange_Tinman = .Cells(1, 1)
            Exit Function
        End If

        flag = False

        Dim r2 As Long, c2 As Long
        For r2 = UBound(data) To r Step -1
            For c2 = UBound(data, 2) To c Step -1
                If Not IsEmpty(data(r2, c2)) Then
                    flag = True
                    Exit For
                End If
            Next
            If flag Then Exit For
        Next

        Set RealUsedRange_Tinman = ws.Range(.Cells(r, c), .Cells(r2, c2))
    End With

End Function

'Changes:
'V2 - Initial version using arrays by Sancarn.
'V3 - IAmNerd2000: Store ubound, lbound to prevent recalculation after compilation.
'V3 - MacroMark:   Added fallback to VBasic2008's version for large ranges
'V4 - Tinman:      Changed Dim a,b,c as x to Dim a as x, b as x, c as x
'V4 - Tinman:      Changed use ur.countLarge instead of .rows.count and .columns.count for 1x1 check
'V4 - Tinman:      Use Value2 instead of Value1
Function ValueRange(sht As Worksheet) As Range
  'Get used range
  Dim ur As Range
  Set ur = sht.UsedRange

  'If used range is 1x1 then result is 1x1
  If ur.CountLarge = 1 Then
    Set ValueRange = ur
    Exit Function
  End If

  'Find via array
  'Get array of all values:
  On Error GoTo URValueError
    Dim v As Variant
    v = ur.Value2
  On Error GoTo 0

  'Offsets if they exist
  Dim offR As Long, offC As Long
  With ur
    offR = .row - 1
    offC = .Column - 1
  End With

  'Define required values
  Dim colMin As Long, colMax As Long, rowMin As Long, rowMax As Long, row As Long, col As Long

  'Find min row:
  Dim ubndR As Long, ubndC As Long, lbndR As Long, lbndC As Long
  lbndR = 1 'should always be 1
  lbndC = 1 'should always be 1
  ubndR = UBound(v, 1)
  ubndC = UBound(v, 2)

  For row = lbndR To ubndR
    For col = lbndC To ubndC
      If Not IsEmpty(v(row, col)) Then
        rowMin = row
        GoTo NextNum
      End If
    Next
  Next
NextNum:
  'Find max row
  For row = ubndR To lbndR Step -1
    For col = lbndC To ubndC
      If Not IsEmpty(v(row, col)) Then
        rowMax = row
        GoTo NextNum2
      End If
    Next
  Next
NextNum2:
  'Find min col:
  For col = lbndC To ubndC
    For row = lbndR To ubndR
      If Not IsEmpty(v(row, col)) Then
        colMin = col
        GoTo NextNum3
      End If
    Next
  Next
NextNum3:
  'Find max col
  For col = ubndC To lbndC Step -1
    For row = lbndR To ubndR
      If Not IsEmpty(v(row, col)) Then
        colMax = col
        GoTo NextNum4
      End If
    Next
  Next
NextNum4:
  Set ValueRange = Range(sht.Cells(offR + rowMin, offC + colMin), sht.Cells(offR + rowMax, offC + colMax))
  Exit Function
URValueError:
  If Err.Number = 7 Then 'Out of memory error:
    'If out of memory, fall back on VBasic2000's version. It's not optimal but it doesn't have memory issues!
    Dim firstCell, lastCell As Range
    With sht
      Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows)
      If Not firstCell Is Nothing Then
        Set lastCell = .Cells.Find("*", .Cells(1048576, 16384), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious)
        Set ValueRange = .Range(firstCell, lastCell)
      End If
    End With
  Else
    'Raise unhandled error
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
  End If
End Function

Sub CreateTestRange()
  Dim arr As Variant
  arr = Split("$B$2,$C$3,$E$4,$D$5,$E$8,$E$9,$F$9,$D$10", ",")
  For i = LBound(arr) To UBound(arr)
    Sheet1.Range(arr(i)).Value2 = IIf(i > 4, "string", i)
  Next
  Range("C13").Formula = "=""cool formula"""
  Range("C14").Formula = "=""""" 'blank formula
  Range("H11").Interior.Color = RGB(255, 255, 0)
End Sub

'If you fail this check then your function is incorrect
Sub testAllFuncs()
  Application.ScreenUpdating = False

  Debug.Print "Iterations: " & ITERATION_MAX
  Debug.Print "-----------------------------------------|--------|-------------|"
  Debug.Print "FUNCTION                                 | Valid? | Performance |"
  Debug.Print "-----------------------------------------|--------|-------------|"
  Debug.Print testAll("Module1.RealUsedRange_Sancarn1")
  Debug.Print testAll("Module1.RealUsedRange_Sancarn2")
  Debug.Print testAll("Module1.RealUsedRange_VBasic2008")
  Debug.Print testAll("Module1.RealUsedRange_IAmNerd2000_1")
  Debug.Print testAll("Module1.RealUsedRange_Sancarn3")
  Debug.Print testAll("Module1.RealUsedRange_IAmNerd2000_2")
  Debug.Print testAll("Module1.RealUsedRange_VBasic2008_refac")
  Debug.Print testAll("Module1.RealUsedRange_Tinman")
  Debug.Print testAll("Module1.ValueRange")

  Application.ScreenUpdating = True
End Sub

Private Function testAll(ByVal funcToRun As String) As String
  Dim s1 As String, s2 As String, s3 As String
  s1 = Left(funcToRun & Space(40), 40)
  s2 = Left(testFunc(funcToRun) & Space(6), 6)
  s3 = Left(testFuncPerf(funcToRun) & Space(11), 11)
  testAll = s1 & " | " & s2 & " | " & s3 & " |"
End Function
Private Function testFunc(ByVal funcToRun As String) As String
  testFunc = IIf(Application.Run(funcToRun, Sheet1).Address = "$B$2:$F$14", "YES", "NO")
End Function
Private Function testFuncPerf(ByVal funcToRun As String) As Double
  StartTimer
    For i = 1 To ITERATION_MAX
      Application.Run funcToRun, Sheet1
    Next
  testFuncPerf = GetTimer()
End Function