Return to Answer

https://pastebin.com/0DLQihvB

https://pastebin.com/zPWKkYtM

Sancarn1: 25092.0285 Sancarn2: 2258.1964 VBasic2008: 34244.5967 Sancarn3: 1578.1883 IAmNerd2000_2: 2709.7776 VBasic2008_refac: 11751.0986 IAmNerd2000_1: 8218.9036 - Disqualified due to incorrect address with formatting outside of value range. 

I had to modify the code I originally posted as it didn't work in some conditions. The test cases are provided below:

https://pastebin.com/iSmLZXqN

The fastest method turned out to be Sancarn3 which came from being inspired by code posted by IAmNerd2000.

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 (if there is an error, this may be an out of memory error. In this case use find()): 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, lastCell1, lastCell2 As Range With sht Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlValues, , XlSearchOrder.xlByRows) If Not firstCell Is Nothing Then Set lastCell1 = .Cells.Find("*", .Cells(1,1), xlFindLookIn.xlValues,, XlSearchOrder.xlByColumns, xlPrevious) Set lastCell2 = .Cells.Find("*", .Cells(1,1), xlFindLookIn.xlValues,, xlSearchOrder.xlByRows, xlPrevious) Set RealUsedRange_Sancarn3 = .Range(firstCell, .Range(lastCell1,lastCell2)) 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  | Valid? | Performance | -----------------------------------------|--------|-------------| Module1.RealUsedRange_Sancarn1 | YES | 76906.5109 | Module1.RealUsedRange_Sancarn2  | YES | 6570.8505 | Module1.RealUsedRange_VBasic2008  | YES | 44600.0445 | Module1.RealUsedRange_IAmNerd2000_1 | NO  | 21472.0677 | Module1.RealUsedRange_Sancarn3  | YES | 5371.9298 | Module1.RealUsedRange_IAmNerd2000_2  | YES | 8423.5989 | Module1.RealUsedRange_VBasic2008_refac | YES | 35906.7597 | Module1.RealUsedRange_Tinman  | NO | 6489.7732 | Module1.ValueRange  | YES | 4930.6771 | 

I had to modify the code I originally posted as it didn't work in some conditions. All test cases are tested with the code below. I've tried to make it easy for you to set up your own test cases by providing a CreateTestRange function. You can test all functions by calling testAllFuncs. You can also add your own functions here also!:

https://pastebin.com/0DLQihvB

The fastest method so far is listed as ValueRange and is a modification of which came from being inspired by code posted by IAmNerd2000.

'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 Value 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 As Range, lastCell1 As Range, lastCell2 As Range With sht Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows) If Not firstCell Is Nothing Then Set lastCell1 = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious) Set lastCell2 = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlFormulas, , XlSearchOrder.xlByRows, xlPrevious) Set ValueRange = .Range(firstCell, Range(lastCell1, lastCell2)) End If End With Else 'Raise unhandled error Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End If End Function 

Edit: Changes based on Tinman's post. Main changes were removing variant references, using CountLarge instead of .Rows.Count=1 and .Columns.Count=1 and Value2 instead of Value

Function RealUsedRange_VBasic2008_refac(sht As Worksheet) As Range Dim firstCell, lastCell 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.xlValues, , 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 lastCell = .Cells.Find("*", .Cells(1048576, 16384), Excel.XlFindLookIn.xlValues, , XlSearchOrder.xlByColumns, xlPrevious) 'Find combined range between first and last cell Set RealUsedRange_VBasic2008_refac = Range(firstCell, lastCell) End If End With 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 (if there is an error, this may be an out of memory error. In this case use find()): 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.xlValues, , XlSearchOrder.xlByRows) If Not firstCell Is Nothing Then Set lastCell = .Cells.Find("*", .Cells(1048576, 16384), XlFindLookIn.xlValues, , 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_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.xlValues, , 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.xlValues, , XlSearchOrder.xlByColumns, xlPrevious)   Set lastCell2 = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlValues, , 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_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 (if there is an error, this may be an out of memory error. In this case use find()): 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, lastCell1, lastCell2 As Range With sht Set firstCell = .Cells.Find("*", .Cells(1, 1), XlFindLookIn.xlValues, , XlSearchOrder.xlByRows) If Not firstCell Is Nothing Then Set lastCell1 = .Cells.Find("*", .Cells(1,1), xlFindLookIn.xlValues,, XlSearchOrder.xlByColumns, xlPrevious) Set lastCell2 = .Cells.Find("*", .Cells(1,1), xlFindLookIn.xlValues,, xlSearchOrder.xlByRows, xlPrevious) Set RealUsedRange_Sancarn3 = .Range(firstCell, .Range(lastCell1,lastCell2)) End If End With Else 'Raise unhandled error Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext End If End Function 

Edit: RealUsedRange_VBasic2008_refac didn't work in some situations. The solution has now been changed to reflect this.