简体   繁体   中英

Excel VBA: How to dynamically enlarge/expand ActiveCell?

I ran across a question in a facebook group which asked how to expand/enlarge/zoom the active cell in an Excel worksheet. Normally, I don't like to mess with the Excel UI visually but I guess that the person must have some form of visual impairment or something which requires a clear and bigger view of the contents of the active cell. I searched in stackoverflow and googled and also in the similar questions box which doesn't show the exact same answer I was searching. I believe that there are multiple possible approaches to this question. 1.to change the rowHeight and columnWidth of the activecell.

Application.ActiveCell.RowHeight=50
Application.ActiveCell.ColumnWidth=50

2.to change the autofit of the column containing activecell.

Application.ActiveCell.EntireColumn.AutoFit

3.to change the zoom level of activewindow.

ActiveWindow.Zoom 50

4.to assign the activecell contents into a textbox.text property on a modeless userform. I think methods 1 & 4 are most likely to work and personally, I prefer method4 because it seems less likely to visually disturb the user.

Workbook_SheetSelectionChange "event will be used

Allow me to answer to my own question with the following VBA code.
Please feel free to improve upon this.

'copy paste into ThisWorkbook module
'explicit error checking was not performed - use at users' own risk
Option Explicit

Const increasedColumnWidth = 50'change how large as per requirement
Const increasedRowHeight = 50

'saved properties to restore later
Private saved_ActiveCell_ColumnWidth As Integer
Private saved_ActiveCell_RowHeight As Integer
Private saved_ActiveCell As Range

'can also be placed into individual worksheet modules but used ThisWorkbook to cover newly inserted sheets
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'very important that sh must be a worksheet<-not checked here
'    If Sh.Name = "Sheet1" Then 'set sheet name here to limit to Sheet1 only or any particular sheet
    If Target.Cells.CountLarge = 1 Then 'if .Count, there may be overflow
        Application.ScreenUpdating = False 'to reduce flashing
        If Target.Value <> "" Then 'or isempty(target.value)
            'restoring previous activecell if there's one
            If Not saved_ActiveCell Is Nothing Then
                saved_ActiveCell.EntireColumn.ColumnWidth = saved_ActiveCell_ColumnWidth
                saved_ActiveCell.EntireRow.RowHeight = saved_ActiveCell_RowHeight
            End If
            'backup
            Set saved_ActiveCell = Target 'Application.ActiveCell
            saved_ActiveCell_ColumnWidth = Target.ColumnWidth
            saved_ActiveCell_RowHeight = Target.RowHeight
            'expanding
            Target.EntireRow.RowHeight = increasedRowHeight
            Target.EntireColumn.ColumnWidth = increasedColumnWidth
        Else'if activecell doesn't contain any value, restore previous activecell to previous size
            If Not saved_ActiveCell Is Nothing Then
                saved_ActiveCell.EntireColumn.ColumnWidth = saved_ActiveCell_ColumnWidth
                saved_ActiveCell.EntireRow.RowHeight = saved_ActiveCell_RowHeight
            End If
        End If
        Application.ScreenUpdating = True
    End If
'    End If
End Sub

Sharing this code doesn't mean that I support messing around with Excel UI manipulation especially those that would disturb the user.
The provided code is just for changing activecell's rowHeight and columnWidth to give the user the visual effect that the activecell is expanded/enlarged.
I've seen other code that would create an image of activecell on-the-fly and gives the user the impression of a zoomed cell here .

The code shared herewith is only for manipulating the rowHeight and columnWidth of the ActiveCell.
The method dealing with a textbox on a modeless userform is still getting improvements and will eventually be available(probably) on my GitHub as a .xlsm file.
Also uploaded a .gif below to clearly display the requirements and the results.
This video .gif contains features not available in the code shared here. 在此处输入图片说明

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM