Hello!
I have a code that looks for a certain string in a excel file, and when it finds it, it copies the specified range around the cell that contains the string and pastes it into another sheet.
My problem: I would like to copy too a possible picture that would be in the specified range, not just the text and formats..
Dim Sir As String
Sir = VBA.InputBox("Input search string")
Application.ScreenUpdating = False
For Sh = 2 To ActiveWorkbook.Worksheets.Count
Sheets(Sh).Select
Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String
With Range("B1:B5000")
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = Range("b1:b5000").Find(What:=Sir, After:=LastCell)
If Not FoundCell Is Nothing ThenFirstAddr = FoundCell.Address
End If
Do Until FoundCell Is Nothing
Sheets(Sh).Range("C6").Copy
With Sheets(1).Range("n1000000").End(xlUp).Offset(1, -12)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
FoundCell.Offset(-6, -1).Range("A1:N29").Select
Selection.Copy
With Sheets(1).Range("n1000000").End(xlUp).Offset(2, -13).Select
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'a
'a
Debug.Print
FoundCell.Address
Set FoundCell = Range("b1:b5000").FindNext(After:=FoundCell)
If FoundCell.Address = FirstAddr ThenExit
Do
End If
Loop
Next Sh
Hi Gigi,
To copy a cell that contains an image, you have to make sure that the image is included completely in that cell, not spread across multiple cells.
The code to copy a cell that includes a shape from A1 to D1 is simple:
Range("A1").Copy Destination:=Range("D1")
OK, Catalin, thanks for your answer!
Currently I do this - non-automated: select the image ---> Ctrl + C ---> select the destination sheet ---> select the destination cell ---> Ctrl + P ....
I imagine that someone could write a sequence of code to test if there is an image in the Range in the previous post {FoundCell.Offset(-6, -1).Range("A1:N29") } (to be copied), to select it, to copy-paste it to the destination sheet in a position relatively identical to the initial position.
Happy New Year!!!
Hi Gigi,
In vba, you cannot search a range for shapes, we can only search in sheet shapes (For each Shp in Sh.Shapes).
I provided the easiest way to copy the images:
Range("A1:N29").Copy Destination:=Range("D1")
I assume that you wanted only values, so you can paste again values only:
Selection.Copy
With Sheets(1).Range("n1000000").End(xlUp).Offset(2, -13).Select
.PasteSpecial xlPasteValues
End With
It is possible though to search through each sheet shape and check if Shp.Top and Shp.Left fit between the range positions.
Dim Shp as Shape, Cell1 as Range, LastCell as Range, NewShape as Shape
Set Cell1=Range("A1:N29").Cells(1)
Set LastCell=Range("A1:N29").Cells(Range("A1:N29").Cells.Count)
For Each Shp in Sh.Shapes
if Shp.Top>Cell1.Top And Shp.Top<LastCell.Top+LastCell.RowHeight And Shp.Left>Cell1.Left And Shp.Left<LastCell.Left+LastCell.ColumnWidth then
Shp.Copy
DestSheet.Paste
Set NewShape=DestSheet.Shapes(DestSheet.Shapes.Count)
'set the position based on original shape position
NewShape.Top=Shp.Top
NewShape.Left=Shp.Left
End If
Next
