Copying images from worksheet to worksheet to the correct cell

[bigtho]

Hi all!

Maybe this has already been asked but anyway....
Im working on an Excel sheet with all the materials from a producer. The goal is that we can make stickers with an QR-code so we can scan this for our date base.

On the main sheet is the next information.

On the second sheet (image 2) I want to make the stickers. The only thing I have the enter is the productcode, then the name (and maybe barcode) will change. (Im doing this with =index/match)

Now im looking into a way that if I change the productcode the QR-code will change to the correct QR-code.
Is there a way to do this without using code? If I do have to use code is there any of you that could help me?

Thanks in advance!

 

[Anthony47]

We can use the Worksheet_Change event of the sheet where you list the materials
For example this code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim CkArea As String, myMatch, PictArea As Range
Dim myC As Range, gSh As Shape

Set PictArea = Sheets("Foglio2").Range("B1:H100")       '<<< Table with Description and QR
CkArea = "J1:J20"                                       '<<< The area where Description will be inserted
'
For Each myC In Target
    If Not Application.Intersect(myC, Range(CkArea)) Is Nothing Then
        myMatch = Application.Match(myC.Value, Application.WorksheetFunction.Index(PictArea, 0, 1), False)
        On Error Resume Next
            ActiveSheet.Shapes("PICT_IN_" & myC.Address(0, 0)).Delete
        On Error GoTo 0
        If Not IsError(myMatch) Then
            Set gSh = GimmePict(myC.Value, PictArea)
            If Not gSh Is Nothing Then
                myC.Select
                gSh.Copy
                ActiveSheet.Paste
                Selection.ShapeRange.Top = myC.Top
                Selection.ShapeRange.Left = myC.Offset(0, 1).Left
                Selection.ShapeRange.Name = "PICT_IN_" & myC.Address(0, 0)
                myC.Select
            End If
        End If
    End If
Next myC
End Sub

Function GimmePict(ByVal Descr As String, ByRef PicArea As Range) As Shape
Dim mySh As Shape
'
For Each mySh In PicArea.Parent.Shapes
    If mySh.Type = msoPicture Or mySh.Type = msoLinkedPicture Then
    Debug.Print PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value
    Debug.Print
        If StrComp(PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value, Descr, vbTextCompare) = 0 Then
            Set GimmePict = mySh
            Exit Function
        End If
    End If
Next mySh
End Function

The lines marked <<< need to be compiled with YOUR information, namely:
-the full address (sheet and range) of the area where the description and the QR are available. The description used need to be the first column in that range
-the range in the second sheet where a description will be written; the QR will be copied in the adjacent column

The code need to be copied into the Code module of the worksheet that will be compiled; from excel:
-rightclick on the tab with the sheet name
-select View Code to open the vba editor at the right page
-copy the code and paste it into empty frame at the right
-adapt the marked lines to your situation

Now return to the worksheet, type a description in the area set and check what happen

Bye

 

[FormR]

Is there a way to do this without using code?

Hi, there is a way outlined here:

Picture Lookup in Excel using Named Ranges

 

[Anthony47]

@FormR
With that metod the user should insert a picture (in column E) for each of the QR he would like to print, and create a dinamic named range for each of those pictures. Probably not very flexible.
Bye

 

[FormR]

and create a dinamic named range for each of those pictures

Hi, no it doesn't work like - only one (dynamic) named range is create.

 

[Anthony47]

Hummm... It depends..
If the user need to show only one QR then your method will definitively be ok (one picture, one dynamic range)
If he need to show several QR in several rows (and this was my interpretation) then the Worksheet_Change method probably is easier to adopt.

By reading again the op request your interpretation is probably the correct one

Bye

 

[bigtho]

It worked. Changed a couple of things to adjust for a second row.
See the changes below:

Sub Worksheet_Change1(Target)
Dim CkArea As String, myMatch, PictArea As Range
Dim myC As Range, gSh As Shape

Set PictArea = Sheets("worksheet").Range("A2:G3000") '<<< Table with Description and QR
CkArea = "A1:A110" '<<< The area where Description will be inserted
'
For Each myC In Target
If Not Application.Intersect(myC, Range(CkArea)) Is Nothing Then
myMatch = Application.Match(myC.Value, Application.WorksheetFunction.Index(PictArea, 0, 1), False)
On Error Resume Next
ActiveSheet.Shapes("PICT_IN_" & myC.Address(0, 0)).Delete
On Error GoTo 0
If Not IsError(myMatch) Then
Set gSh = GimmePict(myC.Value, PictArea)
If Not gSh Is Nothing Then
myC.Select
gSh.Copy
ActiveSheet.Paste
Selection.ShapeRange.Top = myC.Top
Selection.ShapeRange.Left = myC.Offset(0, 1).Left
Selection.ShapeRange.Name = "PICT_IN_" & myC.Address(0, 0)
myC.Select
End If
End If
End If
Next myC
End Sub

Function GimmePict(ByVal Descr As String, ByRef PicArea As Range) As Shape
Dim mySh As Shape
'
For Each mySh In PicArea.Parent.Shapes
If mySh.Type = msoPicture Or mySh.Type = msoLinkedPicture Then
Debug.Print PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value
Debug.Print
If StrComp(PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value, Descr, vbTextCompare) = 0 Then
Set GimmePict = mySh
Exit Function
End If
End If
Next mySh
End Function



Sub Worksheet_Change2(Target)
Dim CkArea As String, myMatch, PictArea As Range
Dim myC As Range, gSh As Shape

Set PictArea = Sheets("worksheet").Range("A2:G3000") '<<< Table with Description and QR
CkArea = "D1:D110" '<<< The area where Description will be inserted
'
For Each myC In Target
If Not Application.Intersect(myC, Range(CkArea)) Is Nothing Then
myMatch = Application.Match(myC.Value, Application.WorksheetFunction.Index(PictArea, 0, 1), False)
On Error Resume Next
ActiveSheet.Shapes("PICT_IN_" & myC.Address(0, 0)).Delete
On Error GoTo 0
If Not IsError(myMatch) Then
Set gSh = GimmePict(myC.Value, PictArea)
If Not gSh Is Nothing Then
myC.Select
gSh.Copy
ActiveSheet.Paste
Selection.ShapeRange.Top = myC.Top
Selection.ShapeRange.Left = myC.Offset(0, 1).Left
Selection.ShapeRange.Name = "PICT_IN_" & myC.Address(0, 0)
myC.Select
End If
End If
End If
Next myC
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

Call Worksheet_Change1(Target)
Call Worksheet_Change2(Target)

End Sub

Really happy with the help!

 

[bigtho]

Sub Worksheet_Change1(Target)
Dim CkArea As String, myMatch, PictArea As Range
Dim myC As Range, gSh As Shape

Set PictArea = Sheets("worksheet").Range("A2:G3000")       '<<< Table with Description and QR
CkArea = "A1:A110"                                       '<<< The area where Description will be inserted
'
For Each myC In Target
    If Not Application.Intersect(myC, Range(CkArea)) Is Nothing Then
        myMatch = Application.Match(myC.Value, Application.WorksheetFunction.Index(PictArea, 0, 1), False)
        On Error Resume Next
            ActiveSheet.Shapes("PICT_IN_" & myC.Address(0, 0)).Delete
        On Error GoTo 0
        If Not IsError(myMatch) Then
            Set gSh = GimmePict(myC.Value, PictArea)
            If Not gSh Is Nothing Then
                myC.Select
                gSh.Copy
                ActiveSheet.Paste
                Selection.ShapeRange.Top = myC.Top
                Selection.ShapeRange.Left = myC.Offset(0, 1).Left
                Selection.ShapeRange.Name = "PICT_IN_" & myC.Address(0, 0)
                myC.Select
            End If
        End If
    End If
Next myC
End Sub

Function GimmePict(ByVal Descr As String, ByRef PicArea As Range) As Shape
Dim mySh As Shape
'
For Each mySh In PicArea.Parent.Shapes
    If mySh.Type = msoPicture Or mySh.Type = msoLinkedPicture Then
    Debug.Print PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value
    Debug.Print
        If StrComp(PicArea.Parent.Cells(mySh.TopLeftCell.Row, PicArea.Cells(1, 1).Column).Value, Descr, vbTextCompare) = 0 Then
            Set GimmePict = mySh
            Exit Function
        End If
    End If
Next mySh
End Function



Sub Worksheet_Change2(Target)
Dim CkArea As String, myMatch, PictArea As Range
Dim myC As Range, gSh As Shape

Set PictArea = Sheets("worksheet").Range("A2:G3000")       '<<< Table with Description and QR
CkArea = "D1:D110"                                       '<<< The area where Description will be inserted
'
For Each myC In Target
    If Not Application.Intersect(myC, Range(CkArea)) Is Nothing Then
        myMatch = Application.Match(myC.Value, Application.WorksheetFunction.Index(PictArea, 0, 1), False)
        On Error Resume Next
            ActiveSheet.Shapes("PICT_IN_" & myC.Address(0, 0)).Delete
        On Error GoTo 0
        If Not IsError(myMatch) Then
            Set gSh = GimmePict(myC.Value, PictArea)
            If Not gSh Is Nothing Then
                myC.Select
                gSh.Copy
                ActiveSheet.Paste
                Selection.ShapeRange.Top = myC.Top
                Selection.ShapeRange.Left = myC.Offset(0, 1).Left
                Selection.ShapeRange.Name = "PICT_IN_" & myC.Address(0, 0)
                myC.Select
            End If
        End If
    End If
Next myC
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

    Call Worksheet_Change1(Target)
    Call Worksheet_Change2(Target)
    
End Sub

 

[Anthony47]

Maybe one single macro using

CkArea = "A1:A110, D1:D110"                               '<<< The area where Description will be inserted

Bye