如何将Excel导航菜单形状关联至列，调整时不影响其他列？

现有功能概述 #

我正在Excel中搭建数据库，首页左侧有一个通过宏实现的导航菜单，目前已完成两个核心功能：

1. 菜单跳转：点击菜单可跳转至对应工作表，代码如下：

Sub menuNav()
Dim menu As String
menu = Right(Application.Caller, Len(Application.Caller) - Len(Left(Application.Caller, 4)))
'MsgBox menu
Application.Sheets(menu).Select
ActiveSheet.Range("C1").Select
End Sub

2. 菜单展开/收缩：点击按钮可切换菜单为仅显示图标（窄版）或图标+文字（宽版），代码如下：

Option Explicit

Dim P1      As Worksheet
Dim xMenu   As ShapeRange
Dim i       As Double
Dim x1      As ShapeRange
Dim x2      As ShapeRange
Dim x3      As ShapeRange
Dim x       As Double
Dim y1Top   As Double
Dim y3Top   As Double
Dim l       As Double
Dim btA As ShapeRange
Dim btD As ShapeRange

Private Sub CreateObjects()

Set P1 = ActiveSheet
Set xMenu = P1.Shapes.Range("MenuPlan")
Set x1 = P1.Shapes.Range("r1")
Set x2 = P1.Shapes.Range("r2")
Set x3 = P1.Shapes.Range("r3")
Set btA = P1.Shapes.Range("btAugmenter")
Set btD = P1.Shapes.Range("btDiminuer")

End Sub

Sub IncreaseEffects()

Call CreateObjects

btA.Visible = msoFalse
btD.Visible = msoCTrue

x = x1.Left

For i = 48 To 35 Step -0.4
    DoEvents
    xMenu.Width = i
    x1.Left = x - 0.4
    x2.Left = x - 0.4
    x3.Left = x - 0.4
    
    x = x - 0.4
Next i

P1.Shapes("txt_Page d'accueil").TextFrame2.TextRange.Font.Fill.Visible = msoTrue

x = x1.Left
l = 19

For i = 35 To 170 Step 20
    DoEvents
    xMenu.Width = i
    
    x1.Left = x + 20
    x2.Left = x + 20
    x3.Left = x + 20
    
    x = x + 20
    
    x2.Width = l
    
    l = l - 3.3
    
    x1.Rotation = 135
    x3.Rotation = -135
    
Next i

y1Top = x1.Top + 6.1222
y3Top = x3.Top - 5.69032

x1.Top = y1Top
x3.Top = y3Top
x = x1.Left

For i = 170 To 180 Step 0.3
    DoEvents
    xMenu.Width = i
    
    x1.Left = x + 0.3
    x2.Left = x + 0.3
    x3.Left = x + 0.3
    
    x = x + 0.3
    
Next i

End Sub

Sub ReduceEffects()

Call CreateObjects

btA.Visible = msoCTrue
btD.Visible = msoFalse

x = x1.Left

For i = 180 To 193 Step 0.3
    DoEvents
    xMenu.Width = i
    x1.Left = x + 0.3
    x2.Left = x + 0.3
    x3.Left = x + 0.3
    
    x = x + 0.3
Next i

P1.Shapes("txt_Page d'accueil").TextFrame2.TextRange.Font.Fill.Visible = msoFalse

x = x1.Left
l = 0

y1Top = x1.Top - 6.1222
y3Top = x3.Top + 5.69032

x1.Top = y1Top
x3.Top = y3Top

For i = 193 To 58 Step -20
    DoEvents
    xMenu.Width = i
    
    x1.Left = x - 20
    x2.Left = x - 20
    x3.Left = x - 20
    
    x = x - 20
    
    x2.Width = l
    
    l = l + 3.3
    
    x1.Rotation = 0
    x3.Rotation = 0
    
Next i

x = x1.Left

For i = 58 To 48 Step -0.3
    DoEvents
    xMenu.Width = i
    
    x1.Left = x - 0.3
    x2.Left = x - 0.3
    x3.Left = x - 0.3
    
    x = x - 0.3
    
Next i

End Sub

需求 #

需要将导航菜单形状关联至指定列，使得菜单尺寸调整时对应列的宽度同步变化，且不影响其他列。

实现方案 #

要实现菜单与列宽的同步，只需在菜单展开/收缩的宏中添加列宽调整代码即可。以下以关联A列为例（可根据实际需求修改列号）：

修改核心逻辑 #

Excel中列宽单位与形状宽度（磅）存在转换关系，默认字体下1列宽≈8.38磅，可根据实际字体调整系数。在菜单尺寸变化的每个循环中，同步更新对应列的宽度。

1. 更新IncreaseEffects过程

在每个For循环的DoEvents后添加列宽同步代码：

' 同步A列宽度，系数可根据实际情况调整
P1.Columns("A").ColumnWidth = xMenu.Width / 8.38

示例（第一个循环修改后）：

For i = 48 To 35 Step -0.4
    DoEvents
    xMenu.Width = i
    ' 新增：同步A列宽度
    P1.Columns("A").ColumnWidth = i / 8.38
    x1.Left = x - 0.4
    x2.Left = x - 0.4
    x3.Left = x - 0.4
    
    x = x - 0.4
Next i

将此代码添加到IncreaseEffects的另外两个For循环中。

2. 更新ReduceEffects过程

同样在每个For循环的DoEvents后添加列宽同步代码：

' 同步A列宽度，系数可根据实际情况调整
P1.Columns("A").ColumnWidth = xMenu.Width / 8.38

示例（第一个循环修改后）：

For i = 180 To 193 Step 0.3
    DoEvents
    xMenu.Width = i
    ' 新增：同步A列宽度
    P1.Columns("A").ColumnWidth = i / 8.38
    x1.Left = x + 0.3
    x2.Left = x + 0.3
    x3.Left = x + 0.3
    
    x = x + 0.3
Next i

将此代码添加到ReduceEffects的另外两个For循环中。

额外优化建议 #

• 精准转换系数：若使用非默认字体，可手动调整列宽后，对比Columns("A").ColumnWidth和Columns("A").Width（磅值）计算准确系数。
• 锁定列宽：若需禁止用户手动调整关联列，可添加保护代码：

' 仅锁定界面操作，不影响宏执行
P1.Protect UserInterfaceOnly:=True
P1.Columns("A").Locked = True

• 性能优化：若动画卡顿，可减少同步频率（如每5次循环同步一次），或在动画结束后一次性设置最终列宽。

内容的提问来源于stack exchange，提问作者Clara Monspiette