请求创建Excel宏：实现剪贴板截图批量规范粘贴功能

以下是满足需求的VBA宏代码，可直接在Excel中使用：

Sub PasteScreenshotToSheet()
    Dim targetSheet As Worksheet
    Dim lastPic As Shape
    Dim newPic As Shape
    Dim targetWidth As Double
    Dim gapHeight As Double
    Dim pasteTop As Double
    Dim pasteLeft As Double
    
    ' 设置目标工作表（可根据实际修改表名）
    Set targetSheet = ThisWorkbook.Worksheets("Sheet1")
    ' 设定目标宽度（30.4cm转换为Excel的磅值）
    targetWidth = CentimetersToPoints(30.4)
    ' 设定截图间的间隙高度（可根据需求调整，这里设为0.5cm）
    gapHeight = CentimetersToPoints(0.5)
    
    ' 获取B列的左侧位置作为对齐基准
    pasteLeft = targetSheet.Columns("B").Left
    
    ' 查找工作表中最后一张图片
    If targetSheet.Shapes.Count > 0 Then
        Set lastPic = targetSheet.Shapes(targetSheet.Shapes.Count)
        ' 计算新截图的顶部位置：最后一张图底部 + 间隙
        pasteTop = lastPic.Top + lastPic.Height + gapHeight
    Else
        ' 如果没有图片，找到蓝色矩形下方位置（假设蓝色矩形是工作表中第一个形状，可根据实际调整）
        ' 若蓝色矩形有特定名称，可改为Set lastPic = targetSheet.Shapes("蓝色矩形名称")
        Set lastPic = targetSheet.Shapes(1)
        pasteTop = lastPic.Top + lastPic.Height + gapHeight
    End If
    
    ' 粘贴剪贴板中的截图
    targetSheet.Paste
    Set newPic = targetSheet.Shapes(targetSheet.Shapes.Count)
    
    ' 设置截图的宽度和对齐方式
    newPic.Width = targetWidth
    newPic.Left = pasteLeft
    ' 按宽度等比例调整高度，避免变形
    newPic.LockAspectRatio = msoTrue
    
    ' 自动调整行高以适配截图（可选）
    targetSheet.Rows(newPic.TopLeftCell.Row).RowHeight = newPic.Height + gapHeight
End Sub

关键功能说明 #

• 宽度匹配与对齐：将截图宽度固定为30.4cm，同时对齐到B列左侧，通过CentimetersToPoints实现单位转换，确保精度。
• 自动定位粘贴位置：通过遍历工作表形状找到最后一张图片，在其下方加上设定的间隙后粘贴新截图；若为首次粘贴，则定位到蓝色矩形下方。
• 间隙设置：代码中gapHeight变量可自由调整，单位为厘米，满足不同间隙需求。
• 比例锁定：开启LockAspectRatio保证截图不会因强制宽度而变形。

使用说明 #

1. 打开Excel，按下Alt + F11打开VBA编辑器。
2. 在左侧工程窗口中右键点击目标工作簿，选择「插入」→「模块」。
3. 将上述代码粘贴到模块窗口中。
4. 回到Excel界面，可通过「开发工具」→「宏」选择PasteScreenshotToSheet运行，或为其添加快捷键/按钮方便使用。

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