How to copy paste columns adjust height of cells with images without distorting the images. (Excel VBA)

Question

Excel as database with images in column:

I would like to make a tool which allows in one sheet the selection of products, all the necessary discount calculations and then print the selection as a quotation for a customer. The table is filtered and then the visible rows copied to another table ready for printing. One of the columns contains images. Images are wisely attached to the cells ("move but NOT size with cells")

• if I filter them, images failed to be filtered, they get superimposed.
• if after filtering I would like to copy them to another table, formatted for printing. They land in accidental locations, not in cell positions where I would like them to land.

Is there a solution to copy and paste images in excel exactly as they are, without changing location and size (attached to destination Cells with VBA?

=== What i tried:

1. The user filters records in a table s/he would like to include in a quotation.

2. By pressing a button s/he runs a macro. It first cleans all drawings and data in target table to which the records will be copied. Then text is copied separately and images separately to their destination columns with the code:

   With Sheets ("QuotationPrint")

       'copy descriptions
   
           Sheets("oferta stal").ListObjects("tblPricelist").ListColumns("Descriptions").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
           .Range("c8").PasteSpecial Paste:=xlPasteAllUsingSourceTheme ', SkipBlanks:=True
   
       'copy images
   
           Sheets("oferta stal").ListObjects("tblPricelist").ListColumns("images").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
           .Range("o8").Select
           ActiveSheet.Paste
   
           .Columns("H:I").Hidden = True
           .Range("n8:n300").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
           .Range("c8:c300").SpecialCells(xlCellTypeVisible).EntireRow.AutoFit
       End With
   

   Here my skills end. What to do to avoid distortion of copied images?

EDIT:

Example data would contain here two columns (for simplifiaction purposes) 1 Table name (listobject.table or data table created with Ctrl+t) is 'tblPriceList.

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

Images are pasted and then they are attached to cell with option "Move but not resize with cell" The user uses filter to select, say row 1 and row 3. then the macro copies selected cells to new empty range starting with (O,8) in antother sheet. After data is pasted cells height are adjusted.

Here is reproducible example excel file showing the problem. Data is first filtered by user. Images fail to get filtered and get copied incorrectly: https://drive.google.com/open?id=1bGXuB47dFqhp9wsYcuBTB7Se6gelPnok

Answer 1

OK, I got something working here:

The CopyVisible function loops through the listobject and checks if the the row is visible, if that is the case the description and all pictures intersecting with the cell. This occures in the right format if one copies more than one cell with a picture in it this gets messed up for a to me unknown reason.

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

This function was copied from Cpearson and helps determine if a cell is visible or not. It can also be used for a range.

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

All in all the problem should be solved with it. A few tips at the end: Declare your variables and force yourself to do it using the Option Explicit try not to use select and activate and if you use listobjects utilize the ability to loop through listrows, listcolumns or the databodyrange.