VBA code to move picture from on sheets to another sheet

[KlausW]

Hello everyone

Anyone who can help, I use this VBA code to move picture from on sheets to another sheet.

Normally the pictures are in a row with the pictures in odd rows from A3 to L3 and A5 to L5 etc., and the employee numbers in the even rows A4 to L4 and A6 to L6. In the formula from A4 to L12. But now I want to take the pictures from B2 to C50. In column B are the pictures and in column C are the employee numbers they must refer to.

Anyone who can help?
Any help will be appreciated

Best Regards
Klaus W

Sub Find()

Dim A, B, c, d As Range ' a = området på "Billeder 1.deling med navne på foto, b = område i "Billeder" med navne på billeder, c = de enkelte celler i a, d = de enkelte celler i b

ActiveSheet.Pictures.Delete ' de gamle billeder slettes

Set A = Range("a4:d4,a8:d8,a12:d12,a16:d16,a20:d20") ' a defineres

Set B = Worksheets("Billeder").Range("a4:L12") ' b defineres

For Each c In A

For Each d In B

If c = d And c <> "" Then ' der testes om de enkelte celler i a findes i b

d.Offset(-1, 0).Copy Destination:=c.Offset(-1, 0) ' hvis de findes, kopieres cellen ovenover i "Billeder" til cellen ovenover i "Billeder 1.deling"

End If

Next

Next

End Sub

I try to modify the Code but it doesn't work.

Sub Find()
    Dim A, B, c, d As Range ' a = området på "Billeder 1.deling med navne på foto, b = område i "Billeder" med navne på billeder, c = de enkelte celler i a, d = de enkelte celler i b
    ActiveSheet.Pictures.Delete ' de gamle billeder slettes
    Set A = Range("a4:d4,a8:d8,a12:d12,a16:d16,a20:d20") ' a defineres
    Set B = Worksheets("Sheet1").Range("b2:c50") ' b defineres
    For Each c In A
        For Each d In B
            If c = d And c <> "" Then ' der testes om de enkelte celler i a findes i b
                d.Offset(-1, 0).Copy Destination:=c.Offset(-1, 0) ' hvis de findes, kopieres cellen ovenover i "Billeder" til cellen ovenover i "Billeder 1.deling"
            End If
        Next
    Next
    
  End Sub

 

[KlausW]

I got the solution myself.

Klaus W

Sub Find()
    Dim A, B, c, d As Range ' a = området på "Billeder 1.deling med navne på foto, b = område i "Billeder" med navne på billeder, c = de enkelte celler i a, d = de enkelte celler i b
    ActiveSheet.Pictures.Delete ' de gamle billeder slettes
    Set A = Range("a4:d4,a8:d8,a12:d12,a16:d16,a20:d20") ' a defineres
    Set B = Worksheets("Sheet1").Range("b2:c42") ' b defineres
    For Each c In A
        For Each d In B
            If c = d And c <> "" Then ' der testes om de enkelte celler i a findes i b
                d.Offset(0, -1).Copy Destination:=c.Offset(-1, 0) ' hvis de findes, kopieres cellen ovenover i "Billeder" til cellen ovenover i "Billeder 1.deling"
            End If
        Next
    Next
    
   'ModifyPic
   
End Sub