Option Explicit
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim meProp As CustomProperty
    For Each meProp In ThisWorkbook.Worksheets(1).CustomProperties
        If meProp.Name = "Zoom_Save" Then ThisWorkbook.Windows(1).Zoom = meProp: meProp.Delete
    Next
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ThisWorkbook.Worksheets(1).CustomProperties.Add "Zoom_Save", ThisWorkbook.Windows(1).Zoom
    ThisWorkbook.Windows(1).Zoom = 100
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ThisWorkbook.Windows(1).Zoom = 100
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ThisWorkbook.Activate
ActiveWindow.Zoom = 100
End Sub

Sub ActiveCellColumnWidthPixelExcel()
Dim scale_
   scale_ = GetScaleColumnWidth(ActiveCell)
   Debug.Print ActiveCell.ColumnWidth * scale_(1) + scale_(2)
   '(ширина столбца в пикселях Excel) =  (ширина в символах) * (пикселей на символ) + (поле ячейки в пикселях). 
End Sub

Function GetScaleColumnWidth(r As Range) As Double()
    Dim Result(1 To 2) As Double
    Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
    Dim ws As Worksheet
    
    Set ws = r.Parent.Parent.Worksheets.Add
    x1 = CDbl(1) 'characters
    x2 = CDbl(255) 'characters
    ws.Columns(1).ColumnWidth = x1
    y1 = ws.Columns(1).Width 'points
    ws.Columns(1).ColumnWidth = x2
    y2 = ws.Columns(1).Width 'points
    ws.Delete
    Result(1) = (y2 - y1) / (x2 - x1) 'points per character
    Result(2) = y1 - x1 * Result(1) 'points
    GetScaleColumnWidth = Result

End Function

Sub ActiveCellColumnWidthPixelExcel()
    Debug.Print ColumnWidthPixelExcel(ActiveCell)
End Sub

Function ColumnWidthPixelExcel(r As Range) As Double
    Dim Result(1 To 2) As Double
    Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
    Dim ws As Worksheet
    
    Set ws = r.Parent.Parent.Worksheets.Add
    x1 = CDbl(1) 'characters
    x2 = CDbl(255) 'characters
    ws.Columns(1).ColumnWidth = x1
    y1 = ws.Columns(1).Width 'points
    ws.Columns(1).ColumnWidth = x2
    y2 = ws.Columns(1).Width 'points
    ws.Delete
    Result(1) = (y2 - y1) / (x2 - x1) 'points per character
    Result(2) = y1 - x1 * Result(1) 'points
    ColumnWidthPixelExcel = (r(1).ColumnWidth * Result(1) + Result(2))

End Function