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:
- The user filters records in a table s/he would like to include in a quotation.
-
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 WithHere 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
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.
Tags: excelexcel, image, vba
