翻转 Excel 文件中的文本

Question

我有一个电子表格（宽 900 个单元格，长 2000 个单元格），其设计需要垂直和水平翻转。

我手动转换了大约 30 个文本框中的文本，然后仅在 Y 轴上应用了 3D 旋转翻转。

在 Excel 中，如果我同时翻转 X 轴和 Y 轴，则不起作用。 但是当我打印为 pdf，然后通过 pdf 打印机再次水平反转它时，它就完美了。

我现在有大约 1000 个带有文本的单元格（不是文本框）。

我希望突出显示一个单元格并运行一个宏来剪切单元格文本，将其粘贴到该单元格中的文本框中，然后将 3D 旋转翻转 180 度。

其中包含文本的单元格大小都不同，我不知道如何自动添加文本框来填充每个单元格。

结果应该是这样的。

代码 - 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")
        
        'check cell is not empty
        If rng.Value <> "" Then
        
            'check cell is part of merged range
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
    
            'create rectangle matching dimensions of range
            Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle( _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            'clear contents of cell
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub

代码 - 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")
        
        'check cell is not empty
        If rng.Value <> "" Then
        
            'check cell is part of merged range
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
    
            'add rectangle matching dimensions of range
            Set shp = ActiveSheet.Shapes.AddShape( _
                Type:=msoShapeRectangle, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            'white background with no lines
            shp.Fill.ForeColor.RGB = rgbWhite
            shp.Line.Visible = msoFalse
            
            'clear contents of cell
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub

Answer 1

您可以使用下面的代码创建一个文本框并设置其位置和尺寸以匹配所选单元格的位置和尺寸。 我不完全清楚您在翻转/旋转方面想要做什么，因此下面的代码假设您想要垂直翻转文本框。

Sub Single_Text_Box()

    Dim shp As Shape
    
    Set shp = ActiveSheet.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=ActiveCell.Left, _
        Top:=ActiveCell.Top, _
        Width:=ActiveCell.Width, _
        Height:=ActiveCell.Height)
    
    shp.TextFrame2.TextRange.Text = ActiveCell.Text
    shp.Flip msoFlipVertical
    
    ActiveCell.ClearContents
    
End Sub

如果您确实想要将 3D Y 轴旋转 180 度，您可以替换以下行：

shp.Flip msoFlipVertical

有了这个：

shp.ThreeD.RotationY = 180

我不确定您是否真的想为 1000 个单元格中的每一个单元格单独运行此宏。 相反，您可以将整个事情包装在一个循环中以处理指定范围内的每个单元格（在下面的示例中我将其限制为 A1:B5）：

Sub Loop_For_Text_Boxes()

    Dim shp As Shape
    Dim rng As Range
    
    For Each rng In Worksheets("Sheet1").Range("A1:B5")
    
        Set shp = ActiveSheet.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=rng.Left, _
            Top:=rng.Top, _
            Width:=rng.Width, _
            Height:=rng.Height)
        
        shp.TextFrame2.TextRange.Text = rng.Text
        shp.Flip msoFlipVertical
    
        rng.ClearContents
        
    Next rng
    
End Sub

上面的代码将向指定范围内的每个单元格添加一个文本框。 如果您想检查包含某些内容的单元格，您可以执行以下操作：

Sub Loop_For_Text_Boxes_Checking_If_Populated()

    Dim shp As Shape
    Dim rng As Range
    
    For Each rng In Worksheets("Sheet1").Range("A1:B5")
        
        If rng.Value <> "" Then
    
            Set shp = ActiveSheet.Shapes.AddTextbox( _
                Orientation:=msoTextOrientationHorizontal, _
                Left:=rng.Left, _
                Top:=rng.Top, _
                Width:=rng.Width, _
                Height:=rng.Height)
            
            shp.TextFrame2.TextRange.Text = rng.Text
            shp.Flip msoFlipVertical
            shp.Flip msoFlipHorizontal
        
            'rng.ClearContents
        
        End If
        
    Next rng
    
End Sub

如果需要处理合并单元格，可以测试MergeCells属性，使用MergeArea属性返回合并单元格的范围：

Sub Loop_For_Text_Boxes_Checking_If_Populated_And_Merged()

    Dim shp As Shape
    Dim rng As Range
    Dim rng2txt As Range
    
    For Each rng In Worksheets("Sheet1").Range("A1:B5")
        
        'check cell is not empty
        If rng.Value <> "" Then
        
            'check cell is part of merged range
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
    
            'create text box matching dimensions of range
            Set shp = ActiveSheet.Shapes.AddTextbox( _
                Orientation:=msoTextOrientationHorizontal, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            'add text and center horizontally and vertically
            With shp.TextFrame2
                .TextRange.Text = rng2txt.Cells(1, 1).Text
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .VerticalAnchor = msoAnchorMiddle
            End With
            
            'rotate 180 degrees on Y axis
            shp.ThreeD.RotationY = 180
            
            'clear contents of cell
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub

编辑以包含背景矩形：

Sub Add_Rectangles_And_Text_Boxes()

    Dim shp As Shape
    Dim rng As Range
    Dim rng2txt As Range
    Dim sh As Worksheet
    
    Set sh = Worksheets("Sheet3")
    
    For Each rng In sh.Range("B2:AET2000")
        
        'check cell is not empty
        If rng.Value <> "" Then
        
            'check cell is part of merged range
            If rng.MergeCells Then
                Set rng2txt = rng.MergeArea
            Else
                Set rng2txt = rng
            End If
            
            'create rectangle matching dimensions of range
            Set shp = sh.Shapes.AddShape( _
                Type:=msoShapeRectangle, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
                
            With shp
                'set fill colour
                .Fill.ForeColor.RGB = rgbWhite
                'remove border
                .Line.Visible = msoFalse
            End With
            
            'create text box matching dimensions of range
            Set shp = sh.Shapes.AddTextbox( _
                Orientation:=msoTextOrientationHorizontal, _
                Left:=rng2txt.Left, _
                Top:=rng2txt.Top, _
                Width:=rng2txt.Width, _
                Height:=rng2txt.Height)
            
            'add text and center horizontally and vertically
            With shp.TextFrame2
                .TextRange.Text = rng2txt.Cells(1, 1).Text
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .VerticalAnchor = msoAnchorMiddle
            End With
            
            With shp
                'rotate 180 degrees on Y axis
                .ThreeD.RotationY = 180
                'remove fill colour
                .Fill.Visible = msoFalse
            End With
            
            'clear contents of cell
            rng2txt.ClearContents
        
        End If
        
    Next rng
    
End Sub