基于单元格时间值调整VBA形状大小的问题求助

我想根据下图中A4:A19的时间刻度，配合F4、G4的时间范围值，调整形状的位置和尺寸，但编写的VBA代码无法正常运行。

原代码 #

Dim z As Range
 
 For Each z In Range("a4:a19").Rows
 If z.Value >= Range("F4") Then Exit For
 Next z

Dim x As Range
 
 For Each x In Range("a4:a19").Rows
 If x.Value >= Range("G4") Then Exit For
 
Next x
'MsgBox z & x
Dim c
Dim rnrn
c = Rows(3).Find(DateValue("12/11/2022")).Column
 'Application.InchesToPoints(10)
Dim LLL As Single, TTT As Single, WWW As Single, HHH As Single
    Set rnrn = Range(z.Address, x.Address).Offset(0, c - 1)
    LLL = rnrn.Left
    TTT = rnrn.Top
    WWW = rnrn.Width
    HHH = rnrn.Height
    With ActiveSheet.Shapes
   ' .LockAspectRatio = msoFalse
      .AddTextbox(msoTextOrientationHorizontal, LLL, TTT + Application.InchesToPoints(Range("F4").Value), WWW, Application.InchesToPoints(Range("F4").Value) + Application.InchesToPoints(Range("G4").Value)).Select
    ' .Placement = xlMove
           ' .LockAspectRatio = msoTrue
    End With
      Dim r1 As Byte, r2 As Byte, r3 As Byte
  r1 = WorksheetFunction.RandBetween(0, 255)
r2 = WorksheetFunction.RandBetween(0, 255)
r3 = WorksheetFunction.RandBetween(0, 255)
     With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(r1, r2, r3)
        .Transparency = 0
        .Solid
    End With
        Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
 With Selection.ShapeRange.TextFrame2.TextRange.Characters.ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With

Selection.ShapeRange.TextFrame2.TextRange.Characters.Font.Size = 15
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Range("F3").Text & " - " & Range("G3").Text

代码问题分析 #

1. 行遍历逻辑缺陷：如果F4/G4的时间比A列所有刻度都大，z/x会指向A20（超出A4:A19范围），后续引用会报错
2. 形状尺寸计算错误：直接将时间值转成英寸是逻辑错误，应该计算时间差对应的行高度占比
3. 依赖Selection不稳定：通过Select操作形状容易因用户操作或环境变化出错，应直接引用对象
4. Find方法无搜索参数：未指定搜索方向，可能找不到目标日期列
5. 位置与高度逻辑混乱：Top和Height的计算未关联行的实际高度，导致形状位置偏移

修正后的代码 #

Sub AdjustShapeByTimeRange()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 可替换为具体工作表，如ThisWorkbook.Worksheets("Sheet1")
    
    Dim timeStart As Date, timeEnd As Date
    timeStart = ws.Range("F4").Value
    timeEnd = ws.Range("G4").Value
    
    ' 查找时间刻度的起始和结束行
    Dim startRow As Long, endRow As Long
    startRow = 4
    For startRow = 4 To 19
        If ws.Cells(startRow, "A").Value >= timeStart Then Exit For
    Next startRow
    ' 确保不超出范围
    startRow = IIf(startRow > 19, 19, startRow)
    
    endRow = 4
    For endRow = 4 To 19
        If ws.Cells(endRow, "A").Value >= timeEnd Then Exit For
    Next endRow
    endRow = IIf(endRow > 19, 19, endRow)
    
    ' 查找目标日期列（12/11/2022）
    Dim targetCol As Long
    Dim findResult As Range
    Set findResult = ws.Rows(3).Find(What:=DateValue("12/11/2022"), LookIn:=xlValues, LookAt:=xlWhole)
    If findResult Is Nothing Then
        MsgBox "未找到目标日期列"
        Exit Sub
    End If
    targetCol = findResult.Column
    
    ' 计算形状的位置和尺寸
    Dim targetRange As Range
    Set targetRange = ws.Range(ws.Cells(startRow, targetCol), ws.Cells(endRow, targetCol))
    
    Dim shapeLeft As Single, shapeTop As Single
    Dim shapeWidth As Single, shapeHeight As Single
    
    shapeLeft = targetRange.Left
    shapeTop = targetRange.Top
    shapeWidth = targetRange.Width
    shapeHeight = targetRange.Height
    
    ' 调整形状位置：如果起始时间在两行之间，按比例偏移Top
    Dim timeDiffStart As Double, rowTimeDiff As Double
    If startRow > 4 Then
        rowTimeDiff = ws.Cells(startRow, "A").Value - ws.Cells(startRow - 1, "A").Value
        timeDiffStart = timeStart - ws.Cells(startRow - 1, "A").Value
        shapeTop = shapeTop - (ws.Rows(startRow).Height * (timeDiffStart / rowTimeDiff))
    End If
    
    ' 调整形状高度：如果结束时间在两行之间，按比例调整高度
    If endRow < 19 Then
        rowTimeDiff = ws.Cells(endRow + 1, "A").Value - ws.Cells(endRow, "A").Value
        timeDiffEnd = ws.Cells(endRow + 1, "A").Value - timeEnd
        shapeHeight = shapeHeight + (ws.Rows(endRow + 1).Height * (timeDiffEnd / rowTimeDiff))
    End If
    
    ' 创建文本框并设置属性（避免使用Selection）
    Dim newShape As Shape
    Set newShape = ws.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=shapeLeft, Top:=shapeTop, _
        Width:=shapeWidth, Height:=shapeHeight)
    
    ' 设置填充颜色
    Dim r1 As Byte, r2 As Byte, r3 As Byte
    r1 = WorksheetFunction.RandBetween(0, 255)
    r2 = WorksheetFunction.RandBetween(0, 255)
    r3 = WorksheetFunction.RandBetween(0, 255)
    With newShape.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(r1, r2, r3)
        .Transparency = 0
        .Solid
    End With
    
    ' 设置文本格式
    With newShape.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        With .TextRange.Characters
            .Text = ws.Range("F3").Text & " - " & ws.Range("G3").Text
            .Font.Size = 15
            .ParagraphFormat.Alignment = msoAlignCenter
        End With
    End With
    
    ' 设置形状随单元格移动
    newShape.Placement = xlMove
End Sub

关键修复说明 #

• 增加了行范围边界检查，避免超出A4:A19导致的错误
• 按时间差比例计算形状的Top偏移和Height调整，匹配时间刻度的行高度
• 直接引用Shape对象替代Selection，提升代码稳定性
• 给Find方法添加了明确的搜索参数，确保找到正确的日期列
• 增加了未找到目标日期的错误提示

内容的提问来源于stack exchange，提问作者Enrique Ferolino