Excel VBA, return column number of column currently in center of screen

[renigar]

Is what I'm asking in the subject possible. I've searched google and can't find anything to help. Thanks for any help you can give.

 

[SkipVought]

hi,

Check out...

Debug.Print ActiveWindow.VisibleRange.Column
Debug.Print ActiveWindow.VisibleRange.Columns.Count

The difference halved plus the start column, gets you the center column.

Function CenterCol()
   ActiveWindow.VisibleRange
      CenterCol = Int((.Columns.Count - .Column) / 2) + .Column
   End With
End Function

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein

 

[combo]

Another approach with API (for screen resolution):

Declare Function GetSystemMetrics32 Lib "User32" _
    Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

Public Sub CellInCenterOfScreen()
Dim X As Long, Y As Long, CellInCentre As Range
X = GetSystemMetrics32(0) / 2 ' width in points / 2
Y = GetSystemMetrics32(1) / 2 ' height in points / 2
With ActiveWindow
    If .RangeFromPoint(X, Y) Is Nothing Then
        MsgBox "no cell in the middle"
    Else
        Set CellInCentre = .RangeFromPoint(X, Y)
        With CellInCentre
            MsgBox "address: " & .Address & vbCrLf & "column: " & .Column, vbOKOnly + vbInformation, "cell in the centre of the screen"
        End With
    End If
End With
End Sub

combo

 

[Andrzejek]

Did you know that instead of:

[highlight #FCE94F]Int[/highlight]((.Columns.Count - .Column) [highlight #FCE94F]/[/highlight] 2) + .Column

you can do:

((.Columns.Count - .Column) [highlight #FCE94F]\[/highlight] 2) + .Column

---- Andy

There is a great need for a sarcasm font.

 

[strongm]

Just to note that Skip's code will get you the center of the center column of th4e application window, not necessarily the center of the screen. And combo's code as given doesn't exactly answer your request (there are plenty of cases where there might not be a cell at the centre of teh screen, but there is a column at the midway point. But a minor change should deal with that:

[blue]Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1


Public Sub example()
    MsgBox GetCenterColumn
End Sub

[COLOR=green]' Based on combo's code[/color]
Private Function GetCenterColumn() As Long [COLOR=green]' returning 0 means no column[/color]
Dim X As Long, Y As Long, CellInCentre As Range
Dim lp As Long

X = GetSystemMetrics(SM_CXSCREEN) / 2 [COLOR=green]' width in points / 2[/color]
Y = GetSystemMetrics(SM_CYSCREEN) / 2 [COLOR=green]' height in points / 2[/color]

With ActiveWindow
    For lp = 1 To GetSystemMetrics(SM_CYSCREEN)
        If Not .RangeFromPoint(X, Y) Is Nothing Then
            GetCenterColumn = .RangeFromPoint(X, Y).Column
            Exit For [COLOR=green]' found center column so no need to continue loop[/color]
        End If
    Next
End With

End Function[/blue]

 

[renigar]

Thanks Guys for the responses. Skip, for a guy who said he was bowing out awhile back, you still come through. Thanks. Combo, I'm a little dense at times and all I got out of yours was the "no cell in the middle" message. I had to lay out the code step by step to understand it better. Below is my test code. It may help beginners looking for something similar.

Sub FindCenter()
' Find the number of the column currently in the center of the screen

X = ActiveCell.Column   ' Test with active cell (BB4, column 54) set at center of screen
Y = ActiveWindow.VisibleRange.Column    ' Column (37) at left side of screen
Z = ActiveWindow.VisibleRange.Columns.Count ' Count of columns on screen (33)
A = Y + (Z / 2)         ' Calculate center column (53.5)

End Sub

 

[strongm]

Just to reiterate - for this to return the column at the center of the screen this column counting code assumes that you are running Excel full screen, that the active sheet running maximised, and that there are no splits or panes configured.

 

[combo]

In addition to strongm's list: sum of widths of columns on the left is close to sum of widths of column on the right.

When using code with API, start with the code in standard module, empty worksheet, make sure there is a cell in the center of the screen, test X and Y values.
Note that RangeFromPoint may return Shape if it is in the middle, so except of testing for Nothing check if yoy have range returned.

combo

 

[renigar]

Thanks again guys for the tips. I wanted to share why I wanted to know this. I read a post somewhere asking for a way to keep a legend on screen for a large sheet they where editing and most of the replies suggested to create a user form. I had a similar need but like to keep thing as simple as possible, at least for my mind. My sheet is used to track employee time off without pre-approval in our department. We have various time off codes that are used by payroll. So I wanted to keep the time off codes in the center of the screen as the user scrolls left or right. Since there are a number of narrow rows and columns, I also have the date you are editing for print at the top of the column your editing even though the dates for the year are in column B. See code below.

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

' Set Variables
Dim EditDate As Date        ' Holds the date you are currently editing
Dim AddrCell1 As String     ' Holds the cell address of the last edit message (the date)
Dim AddrCell2 As String     ' Holds the cell address of the last edit message (your legend)
Dim Y As Long               ' Holds the number of the column currently on left side of screen
Dim Z As Long               ' Holds the count of columns visible on screen
Dim X As Long               ' Holds the target column number for the "Off Codes" (legend)

ActiveSheet.Unprotect

' Read value of cell BB1 & BF1 (used to store address of last edit messages, good for next time you open file)
AddrCell1 = Range("BB1").Value
AddrCell2 = Range("BF1").Value

' Delete last edit messages if they exists
If AddrCell1 <> "" Then
    Range(AddrCell1).ClearContents: Range(AddrCell2).ClearContents
End If

' Check if selected cell is in edit range, if so
If Not Application.Intersect(ActiveCell, Range("C8:AV373")) Is Nothing Then
    If Selection.Count = 1 Then
        If Not Intersect(Target, ActiveCell) Is Nothing Then
' Get date from current row, column B
            EditDate = Range("B" & ActiveCell.Row)
' Print message in row 1 of current column
            Cells(1, ActiveCell.Column) = "You are editing for " & EditDate
' Find which cell is closest to the center
            Y = ActiveWindow.VisibleRange.Column        ' Column at left side of screen
            Z = ActiveWindow.VisibleRange.Columns.Count ' Count of columns on screen
            X = Y + (Z / 2): X = Round(X)               ' Calculate center column
' Print Off Codes on screen (or whatever text you want to stay centered on screen)
            Cells(2, X) = _
            "Vacation Unsched.= 602, Comp Time Unsched.= 604, Sick Unsched.= 606, Family Sick Unsched.=608, Floating Hol Unsched.=611, Worker's Comp= 613, Bereavement=614"
' Get address of cells where messages were written
            AddrCell1 = Cells(1, ActiveCell.Column).Address
            AddrCell2 = Cells(2, X).Address
' Write that addresses in cell BB1 & cell BF1, so they are available for next run
            Range("BB1").Value = AddrCell1
            Range("BF1").Value = AddrCell2
        End If
    End If
End If

ActiveSheet.Protect

End Sub