Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Debug.Print ActiveWindow.VisibleRange.Column
Debug.Print ActiveWindow.VisibleRange.Columns.Count
Function CenterCol()
ActiveWindow.VisibleRange
CenterCol = Int((.Columns.Count - .Column) / 2) + .Column
End With
End Function
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
[highlight #FCE94F]Int[/highlight]((.Columns.Count - .Column) [highlight #FCE94F]/[/highlight] 2) + .Column
((.Columns.Count - .Column) [highlight #FCE94F]\[/highlight] 2) + .Column
[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]
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
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