Finding the middle cell of a range with VBA

M

musoguy

Board Regular
Joined
May 20, 2008
Messages
173
Is it possible to find the middle cell of a range with VBA? The range will be decided by a number of circumstances so I don't know in advance what the range will be.
For example, if the range is A1:A9 I would like a cell reference of A5 returned. If the range is A1:A10, it could return A5 or A6, it doesn't matter to me.

James
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
Possibly like this. It can be used as a worksheet function

Code: 
Function Middle(r As Range) As Variant
Dim i As Long, j As Long
If r.Columns.Count > 1 Then
    Middle = [#N/A]
    Exit Function
End If
i = r.Row
j = r.Rows.Count
Middle = Cells(i + (j - 1) / 2, r.Column).Address(False, False)
End Function

Excel Workbook
A
1A5
2A6
3B10
4#N/A
Sheet1
 
Upvote 0
For a non VBA method you can try the formula below which applies to range A1:A10. adapt the range as required.

=CELL("address",INDEX(A1:A10,ROWS(A1:A10)/2))
 
Upvote 0
Thanks Jaafar, but it does need to done in VBA as it's a small part of a larger macro.

Peter I've hit a problem with your code, and for the life of me I can't figure out why it is the case. Here is the code. It's two functions and a sub (yours being the second function.) It's the sub that is causing the issue:
Code: 
Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False)
        If Not c Is Nothing Then
            Set Find_Range = c
            FirstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
     
End Function


Function Middle(r As Range) As Variant
Dim i As Long, j As Long
If r.Columns.Count > 1 Then
    Middle = [#N/A]
    Exit Function
End If
i = r.Row
j = r.Rows.Count
Middle = Cells(i + (j - 1) / 2, r.Column).Address
End Function



Sub FindMiddleCell()
Dim MyRange1, MyRange2, MyRange3, MyRange4 As Range
Dim MiddleCell1, MiddleCell2, MiddleCell3, MiddleCell4 As Variant

'Using the Find_Range function from above to find the numbers 1,2,3 and 4 within the range M1:M100 and return the range
'The "MyRange" variables are then used in other places in the code as well as here.

Set MyRange1 = Find_Range(1, Range("M1:M100"), xlFormulas, xlWhole)
Set MyRange2 = Find_Range(2, Range("M1:M100"), xlFormulas, xlWhole)
Set MyRange3 = Find_Range(3, Range("M1:M100"), xlFormulas, xlWhole)
Set MyRange4 = Find_Range(4, Range("M1:M100"), xlFormulas, xlWhole)


'Using your Function to find the middle cell address.
'Altered the final line of your Function code to return an absolute reference.

MiddleCell1 = Middle(Range(MyRange1.Address))
MiddleCell2 = Middle(Range(MyRange2.Address))
MiddleCell3 = Middle(Range(MyRange3.Address))
MiddleCell14 = Middle(Range(MyRange4.Address))

'The following test works with MiddleCells 1,2 and 3 but not 4
MsgBox MiddleCell4

End Sub
If I check the variables MiddleCell 1, 2 or 3 they all work, but MiddleCell4 is coming back blank. Originally I had the dimension of the MiddleCell variables as "Range" and using the "Set" command which made sense to me, but it kept coming back with an error. The only way I could get anything to work was to dim them as a variant (I'm guessing because that is what your function does?)

I am so confused!
 
Upvote 0
Figured it out. It was a typo! I wrote
Code: 
MiddleCelll4 = Middle(Range(MyRange4.Address))
instead of
Code: 
MiddleCell4 = Middle(Range(MyRange4.Address))
I'm an idiot!
 
Upvote 0
musoguy said:
Figured it out. It was a typo! I wrote
Code: 
MiddleCelll4 = Middle(Range(MyRange4.Address))
instead of
Code: 
MiddleCell4 = Middle(Range(MyRange4.Address))
I'm an idiot!
Click to expand...
I only part of this that I would agree you are an "idiot" is because you are not using Option Explicit which would have pointed you to the problem immediately. Option Explicit requires you to declare all variables beforehand so that if you use a variable that was not declared, VB stops and tells you. Think about if your problem had involved a numeric value that was to be used in calculations later on and that you made the same kind of typing error... you would have set the correct value into a variable you never used again and all your calculations afterwards would have been wrong... and you might never know it (unless the magnitude of the error was such as to raise suspicion). Using Option Explicit is a good thing to do. You can automate its use by clicking Tools/Options on the VB editor's menu bar and checking the "Require Variable Declaration" checkbox. While you are there, you might as well uncheck the "Auto Syntax Check" checkbox (syntax will still be red, but you won't be interrupted into having to deal with it immediately).
 
Upvote 0
That's makes sense Rick, I have only recently started to get the hang of using the Dim command at the beginning of a Sub, and while I knew about Option Explicit, I didn't realize why it was so useful until you just explained it. The other tip is also going to save me a lot of anger, as the Auto Syntax Check has been driving me crazy when I am copying and pasting something before finishing a line of code, so that is great to know. Maybe I was a little hard on myself! I am learning! :)

James
 
Upvote 0
The below provides a better encapsulation of the issue and returns the cell address from the middle of any range, rounded towards the left and top by default, but settable by the user

Code: 
Public Function CellInTheMiddle(CellAddress As String, Optional TowardsLeft As Boolean = True, Optional TowardsTop As Boolean = True) As String
'
' CellInTheMiddle Public Function
'
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-19 by Timothy Daniel Cox
'
' Returns the middle cell from a range - users can choose whether to round towards the left and towards the top
'
' Uses: CellReference, ColumnAsLetter
' References: N/A
'
    Dim RowCount As Long, ColumnCount As Long, ReturnColumn As Long, ReturnRow As Long
    If CellReference(CellAddress) Then
        ColumnCount = Range(CellAddress).Columns.Count
        RowCount = Range(CellAddress).Rows.Count
        ReturnColumn = Range(CellAddress).Column
        ReturnRow = Range(CellAddress).Row
        If ColumnCount > 1 And Not TowardsLeft Then ReturnColumn = Round(ReturnColumn + ((ColumnCount - 1) / 2))
        If ColumnCount > 1 And TowardsLeft Then ReturnColumn = Round(ReturnColumn + ((ColumnCount - 1) / 2) - 0.5)
        If RowCount > 1 And Not TowardsTop Then ReturnRow = Round(ReturnRow + ((RowCount - 1) / 2))
        If RowCount > 1 And TowardsTop Then ReturnRow = Round(ReturnRow + ((RowCount - 1) / 2) - 0.5)
        CellInTheMiddle = ColumnAsLetter(ReturnColumn) & ReturnRow
    Else
        CellInTheMiddle = "Invalid Cell Reference"
    End If
End Function


Private Function CellReference(CellAddress As String) As Boolean
'
' CellReference Function
'
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-19 by Timothy Daniel Cox
'
' Checks if a Cell Reference is valid - does this by causing an error if a range cannot be set and only setting true if not
'
' Uses: N/A
' References: N/A
'
On Error Resume Next
    Dim TempCell
    TempCell = "ChecksForBlank"
    CellReference = False
    TempCell = Range(CellAddress).Address
    If TempCell = CellAddress Then CellReference = True
End Function

Private Function ColumnAsLetter(ColumnNumber As Long) As String
'
' ColumnAsLetter Function
'
' based on Number2Letter macro (www.thespreadsheetguru.com/the-code-vault/vba-code-to-convert-column-number-to-letter-or-letter-to-number)
' published 2017-07-10 by Chris Newman
' last edited 2018-10-05 by Timothy Daniel Cox
'
' Convert a given number into its corresponding Letter Reference
'
' Uses: N/A
' References: N/A
'
On Error Resume Next
    ColumnAsLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
End Function


There are 3 macros above, but CellReference (which checks if what you have passed is a valid cell reference) could be removed and ColumnAsLetter could easily have it's single line combined into CellInTheMiddle (as below)

Code: 
Public Function CellInTheMiddle(CellAddress As String, Optional TowardsLeft As Boolean = True, Optional TowardsTop As Boolean = True) As String
'
' CellInTheMiddle Public Function
'
' includes code published 2017-07-10 by Chris Newman (www.thespreadsheetguru.com/the-code-vault/vba-code-to-convert-column-number-to-letter-or-letter-to-number)
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-19 by Timothy Daniel Cox
'
' Returns the middle cell from a range - users can choose whether to round towards the left and towards the top
'
' Uses: N/A
' References: N/A
'
    Dim RowCount As Long, ColumnCount As Long, ReturnColumn As Long, ReturnRow As Long
        ColumnCount = Range(CellAddress).Columns.Count
        RowCount = Range(CellAddress).Rows.Count
        ReturnColumn = Range(CellAddress).Column
        ReturnRow = Range(CellAddress).Row
        If ColumnCount > 1 And Not TowardsLeft Then ReturnColumn = Round(ReturnColumn + ((ColumnCount - 1) / 2))
        If ColumnCount > 1 And TowardsLeft Then ReturnColumn = Round(ReturnColumn + ((ColumnCount - 1) / 2) - 0.5)
        If RowCount > 1 And Not TowardsTop Then ReturnRow = Round(ReturnRow + ((RowCount - 1) / 2))
        If RowCount > 1 And TowardsTop Then ReturnRow = Round(ReturnRow + ((RowCount - 1) / 2) - 0.5)
        CellInTheMiddle = Split(Cells(1, ReturnColumn).Address, "$")(1) & ReturnRow
End Function
 
Upvote 0
Further testing has revealed a small bug which is corrected below. As I can't edit, I've reposted.

The below provides a better encapsulation of the issue and returns the cell address from the middle of any range, rounded towards the left and top by default, but settable by the user

Code: 
Public Function CellInTheMiddle(CellAddress As String, Optional TowardsLeft As Boolean = True, Optional TowardsTop As Boolean = True) As String'
' CellInTheMiddle Public Function
'
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-22 by Timothy Daniel Cox
'
' Returns the middle cell from a range - users can choose whether to round towards the left and towards the top
'
' Uses: CellReference, ColumnAsLetter
' References: N/A
'
    Dim RowCount As Long, ColumnCount As Long, ReturnColumn As Long, ReturnRow As Long
    If CellReference(CellAddress) Then
        ColumnCount = Range(CellAddress).Columns.Count
        RowCount = Range(CellAddress).Rows.Count
        ReturnColumn = Range(CellAddress).Column
        ReturnRow = Range(CellAddress).Row
        If ColumnCount > 1 And Not TowardsLeft Then ReturnColumn = Round(ReturnColumn + (ColumnCount / 2), 0)
        If ColumnCount > 1 And TowardsLeft Then ReturnColumn = Round(ReturnColumn + (ColumnCount / 2) - 0.5, 0)
        If RowCount > 1 And Not TowardsTop Then ReturnRow = Round(ReturnRow + (RowCount / 2), 0)
        If RowCount > 1 And TowardsTop Then ReturnRow = Round(ReturnRow + (RowCount / 2) - 0.5, 0)
        CellInTheMiddle = ColumnAsLetter(ReturnColumn) & ReturnRow
    Else
        CellInTheMiddle = "Invalid Cell Reference"
    End If
End Function


Private Function CellReference(CellAddress As String) As Boolean
'
' CellReference Function
'
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-19 by Timothy Daniel Cox
'
' Checks if a Cell Reference is valid - does this by causing an error if a range cannot be set and only setting true if not
'
' Uses: N/A
' References: N/A
'
On Error Resume Next
    Dim TempCell
    TempCell = "ChecksForBlank"
    CellReference = False
    TempCell = Range(CellAddress).Address
    If TempCell = CellAddress Then CellReference = True
End Function

Private Function ColumnAsLetter(ColumnNumber As Long) As String
'
' ColumnAsLetter Function
'
' based on Number2Letter macro (www.thespreadsheetguru.com/the-code-vault/vba-code-to-convert-column-number-to-letter-or-letter-to-number)
' published 2017-07-10 by Chris Newman
' last edited 2018-10-05 by Timothy Daniel Cox
'
' Convert a given number into its corresponding Letter Reference
'
' Uses: N/A
' References: N/A
'
On Error Resume Next
    ColumnAsLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
End Function


There are 3 macros above, but CellReference (which checks if what you have passed is a valid cell reference) could be removed and ColumnAsLetter could easily have it's single line combined into CellInTheMiddle (as below)

Code: 
Public Function CellInTheMiddle(CellAddress As String, Optional TowardsLeft As Boolean = True, Optional TowardsTop As Boolean = True) As String
'
' CellInTheMiddle Public Function
'
' includes code published 2017-07-10 by Chris Newman (www.thespreadsheetguru.com/the-code-vault/vba-code-to-convert-column-number-to-letter-or-letter-to-number)
' Created 2018-10-19 by Timothy Daniel Cox
' last edited 2018-10-22 by Timothy Daniel Cox
'
' Returns the middle cell from a range - users can choose whether to round towards the left and towards the top
'
' Uses: N/A
' References: N/A
'
    Dim RowCount As Long, ColumnCount As Long, ReturnColumn As Long, ReturnRow As Long
        ColumnCount = Range(CellAddress).Columns.Count
        RowCount = Range(CellAddress).Rows.Count
        ReturnColumn = Range(CellAddress).Column
        ReturnRow = Range(CellAddress).Row
        If ColumnCount > 1 And Not TowardsLeft Then ReturnColumn = Round(ReturnColumn + (ColumnCount / 2), 0)
        If ColumnCount > 1 And TowardsLeft Then ReturnColumn = Round(ReturnColumn + (ColumnCount / 2) - 0.5, 0)
        If RowCount > 1 And Not TowardsTop Then ReturnRow = Round(ReturnRow + (RowCount  / 2), 0)
        If RowCount > 1 And TowardsTop Then ReturnRow = Round(ReturnRow + (RowCount / 2) - 0.5, 0)
        CellInTheMiddle = Split(Cells(1, ReturnColumn).Address, "$")(1) & ReturnRow
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Can you add NULL (not Blank "") to an If statement in a formula?
2
Replies
15
Views
995
MARK858
MARK858
KlausW
  • Solved
VBA code to move picture from on sheets to another sheet
Replies
1
Views
57
KlausW
KlausW
P
  • Locked
  • Question Question
VBA: how to refer to an element in a named range (array/matrix)
Replies
1
Views
386
Fluff
Fluff
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
F
  • Question Question
Deleting table column not counting as a change in range
Replies
2
Views
150
Fudging
F

Forum statistics

Threads
1,224,520
Messages
6,179,266
Members
452,902
Latest member
Knuddeluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top