如何复制粘贴列在不扭曲图像的情况下调整图像单元格的高度。（Excel VBA）

列中包含图像的Excel作为数据库：

我想做一个工具，允许在一张纸上选择产品，所有必要的折扣计算，然后打印选择作为客户的报价。 该表将被过滤，然后可见行将复制到另一个表中，以便打印。 其中一列包含图像。图像明智地附加到单元格（“移动，但不随单元格调整大小”）

• 如果我过滤它们，图像过滤失败，它们会被叠加
• 如果在过滤之后，我想将它们复制到另一个表中，格式化以供打印。它们降落在意外地点，而不是我希望它们降落的牢房位置

是否有一种解决方案可以在不改变位置和大小（使用VBA连接到目标单元格）的情况下，准确地复制和粘贴excel中的图像

=== 我尝试的是：

用户筛选要包含在报价单中的表中的记录

通过按下按钮，他/她运行一个宏。它首先清除目标表中记录将复制到的所有图形和数据。然后分别将文本和图像复制到其目标列，代码为：

附页（“报价打印”）

我的技能到此为止。如何避免复制图像的失真

编辑：

示例数据在这里包含两列（为了简化操作） 1表名（listobject.Table或使用Ctrl+t创建的数据表） 这是一个“tblPriceList”

Descriptions | images
------------------------
Lorem ipsum..| image1
Lorem muspi..| image2
meroL ipsum..| image3

粘贴图像，然后使用“移动但不使用单元格调整大小”选项将图像附加到单元格。用户使用过滤器进行选择，例如第1行和第3行。然后宏将所选单元格复制到另一个工作表中以（O，8）开头的新空区域。粘贴数据后，调整单元格高度

---

下面是显示问题的可复制示例excel文件。数据首先由用户过滤。图像无法过滤且复制不正确：

好的，我在这里找到了一些工作：

CopyVisible函数在listobject中循环并检查行是否可见，如果是，说明和所有与单元格相交的图片是否可见。如果复制多个单元格并在其中包含图片，则会以正确的格式发生这种情况，原因不明

Option Explicit ' use this

Public Sub CopyVisible()
Dim SSheet As Worksheet ' Source
Dim TSheet As Worksheet  ' Target
Dim Scell As Range ' Target
Dim Tcell As Range 'Source
Dim Tbl As ListObject
Dim offset As Integer
Dim Pic As Shape
Dim Picrng As Range

Set TSheet = Worksheets("QuotationPrint")
Set SSheet = Worksheets("oferta stal")
Set Tbl = SSheet.ListObjects(1)

TSheet.Range("b8:o300").ClearContents  'remove everything below row 8
'Call DeletePicAll


Set Tcell = TSheet.Range("c8")

offset = 10 ' "from c8 to o8 the offset is 10

For Each Scell In Tbl.ListColumns(1).DataBodyRange  ' loop through table
    If IsVisible(Scell)(1, 1) Then ' only copy if visible

        'description
        Scell.Copy
        Tcell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme ', SkipBlanks:=True
        Tcell.EntireRow.AutoFit

        'image
        For Each Pic In SSheet.Shapes
            Set Picrng = Range(Pic.TopLeftCell.Address & ":" & Pic.BottomRightCell.Address)
            If Not Intersect(Picrng, Scell.offset(0, 1)) Is Nothing Then
                Pic.Copy
                Tcell.offset(0, offset).PasteSpecial
            End If
        Next

    Set Tcell = Tcell.offset(1, 0)
    End If
Next Scell

End Sub

此函数是从中复制的，有助于确定单元格是否可见。它也可用于范围

Public Function IsVisible(InRange As Range) As Boolean()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsVisible
' This function returns an array of Boolean values indicating whether the
' corresponding cell in InRange is visible.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim R As Range
    Dim Arr() As Boolean
    Dim RNdx As Integer
    Dim CNdx As Integer

    ReDim Arr(1 To InRange.Rows.Count, 1 To InRange.Columns.Count)
    For RNdx = 1 To InRange.Rows.Count
        For CNdx = 1 To InRange.Columns.Count
            Set R = InRange(RNdx, CNdx)
            If R.EntireRow.Hidden = True Or R.EntireColumn.Hidden = True Then
                Arr(RNdx, CNdx) = False
            Else
                Arr(RNdx, CNdx) = True
            End If
        Next CNdx
    Next RNdx
    IsVisible = Arr
End Function

---

总之，这个问题应该用它来解决。最后有几点提示：声明变量并强制自己使用

选项Explicit

尝试，如果您使用

列表对象

，请利用循环功能来循环

列表行

，

列表列

或您能提供的

数据源范围

一个示例数据集，可能还有变形前后图片的图像？@LucasRaphaelPianegonda我添加了一个文件，其中包含可复制的示例，一个正在工作的makro，源表中的数据由用户先过滤。好的，我现在可以复制这个问题。我还无法想出一个解决方案。但我正在处理它。您需要循环通过亲爱的Lucas，让我下周测试一下，我会把它标记为好答案，我非常感谢，我也会在链接中研究你的建议。

Public Function IsVisible(InRange As Range) As Boolean()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsVisible
' This function returns an array of Boolean values indicating whether the
' corresponding cell in InRange is visible.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim R As Range
    Dim Arr() As Boolean
    Dim RNdx As Integer
    Dim CNdx As Integer

    ReDim Arr(1 To InRange.Rows.Count, 1 To InRange.Columns.Count)
    For RNdx = 1 To InRange.Rows.Count
        For CNdx = 1 To InRange.Columns.Count
            Set R = InRange(RNdx, CNdx)
            If R.EntireRow.Hidden = True Or R.EntireColumn.Hidden = True Then
                Arr(RNdx, CNdx) = False
            Else
                Arr(RNdx, CNdx) = True
            End If
        Next CNdx
    Next RNdx
    IsVisible = Arr
End Function