Excel单元格文本转文本框并180度3D旋转自动化宏需求求助

需求说明 #

我有一个900列×2000行的Excel表格，设计要求同时进行垂直和水平翻转。手动处理了约30个文本框，仅对其应用Y轴3D旋转翻转后，发现Excel中同时翻转X轴和Y轴无法达到预期效果，但先打印为PDF再通过PDF打印机进行水平反转即可得到完美效果。

目前还有约1000个含文本的单元格（非文本框），需要实现一个宏：选中单元格后运行宏，将单元格文本剪切至该单元格内的文本框中，并对文本框进行180度3D旋转。这些单元格尺寸各不相同，需要自动添加匹配单元格大小的文本框。预期效果如下：

用户原有代码 #

CODE - 8月20日 #

Sub Loop_For_Rectangle_Checking_If_Populated_And_Merged()

    Dim shp As Shape
    Dim rng As Range
    Dim rng2txt As Range
    
    For Each rng In Worksheets("Sheet3").Range("B2:AET2000")
        
        '检查单元格是否非空
        If rng.Value <> "" Then
        
            '检查单元格是否属于合并区域
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
    
            '创建与区域尺寸匹配的矩形
            Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle( _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            '清空单元格内容
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub

CODE - 8月22日 #

Sub Loop_Add_White_Rectangle_Checking_If_Populated_And_Merged()

    Dim shp As Shape
    Dim rng As Range
    Dim rng2txt As Range
    
    For Each rng In Worksheets("Sheet3").Range("B2:AET2000")
        
        '检查单元格是否非空
        If rng.Value <> "" Then
        
            '检查单元格是否属于合并区域
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
    
            '添加与区域尺寸匹配的矩形
            Set shp = ActiveSheet.Shapes.AddShape( _
                Type:=msoShapeRectangle, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            '白色背景且无轮廓线
            shp.Fill.ForeColor.RGB = rgbWhite
            shp.Line.Visible = msoFalse
            
            '清空单元格内容
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub

改进后的宏代码 #

Sub ConvertCellsToFlippedTextBoxes()
    Dim shp As Shape
    Dim rng As Range
    Dim rng2txt As Range
    Dim targetSheet As Worksheet
    
    '设置目标工作表，可根据实际修改
    Set targetSheet = ThisWorkbook.Worksheets("Sheet3")
    
    '遍历选中的单元格区域
    For Each rng In Selection
        '跳过空单元格
        If rng.Value <> "" Then
            '处理合并单元格
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
            
            '创建匹配单元格尺寸的文本框（矩形形状）
            Set shp = targetSheet.Shapes.AddShape( _
                Type:=msoShapeRectangle, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            '设置文本框样式：白色填充、无轮廓
            shp.Fill.ForeColor.RGB = rgbWhite
            shp.Line.Visible = msoFalse
            
            '将单元格文本转移到文本框
            shp.TextFrame2.TextRange.Text = rng2txt.Value
            '继承单元格的字体格式
            shp.TextFrame2.TextRange.Font.Name = rng2txt.Font.Name
            shp.TextFrame2.TextRange.Font.Size = rng2txt.Font.Size
            shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = rng2txt.Font.Color
            
            '设置文本框垂直水平居中
            shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
            shp.TextFrame2.HorizontalAnchor = msoAnchorCenter
            
            '应用180度3D旋转（Y轴翻转，实现水平+垂直翻转效果）
            shp.ThreeD.RotationY = 180
            
            '清空原单元格内容
            rng2txt.ClearContents
        End If
    Next rng
End Sub

代码改进说明 #

• 支持选中区域处理：改为遍历用户选中的单元格，而非固定区域，操作更灵活
• 文本转移与格式继承：不仅转移文本内容，还继承原单元格的字体名称、大小、颜色，保持样式一致性
• 文本对齐优化：设置文本框内文本垂直水平居中，匹配原单元格的显示效果
• 添加3D旋转：通过RotationY = 180实现文本的180度翻转，满足设计需求
• 修复语法错误：修正了8月20日代码中AddShape的参数格式错误

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