Hi
misschien kan iemand mij helpen.
Als organisatie zijn wij overgegaan naar Teams en staat alle data nu dus daar.
Wij werken met een aantal excel files met macro's die informatie uit een werkmap (foto's) moet verwerken in een ander bestand.
Nu werkt echter de macro niet meer wanneer deze algemeen is. De enige optie is om per persoon een link van die werkmap aan de persoonlijke Onedrive toe te voegen en dan een individuele versie van de template te maken.
Is er iemand die weet hoe ik de onderstaande code meer generiek kan maken zodat die lokale verwijzing weg kan? Het gaat om het stukje dat roodgemarkeerd is
Sub Insert_Pict3()
Dim Sh As Shape
With Worksheets("Stands & Displays")
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("a21:a5000")) Is Nothing Then
If Sh.Type = msoPicture Then Sh.Delete
End If
Next Sh
End With
Const Afb_map = "\\C:\Users\WillemsM\OneDrive - elho\2016_packshots ean LR"
myarray = WorksheetFunction.Transpose(Range("b21", Range("b" & Rows.Count).End(xlUp)).Value)
ActiveSheet.Protect False, False, False, False, False
If Not IsArray(myarray) Then Exit Sub
On Error Resume Next
lRow = 21
For lLoop = LBound(myarray) To UBound(myarray)
Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
Cells(2, 1).Left + 19, Cells(lRow, 2).Top + 8, 50, 50)
lRow = lRow + 1
Next lLoop
End Sub
misschien kan iemand mij helpen.
Als organisatie zijn wij overgegaan naar Teams en staat alle data nu dus daar.
Wij werken met een aantal excel files met macro's die informatie uit een werkmap (foto's) moet verwerken in een ander bestand.
Nu werkt echter de macro niet meer wanneer deze algemeen is. De enige optie is om per persoon een link van die werkmap aan de persoonlijke Onedrive toe te voegen en dan een individuele versie van de template te maken.
Is er iemand die weet hoe ik de onderstaande code meer generiek kan maken zodat die lokale verwijzing weg kan? Het gaat om het stukje dat roodgemarkeerd is
Sub Insert_Pict3()
Dim Sh As Shape
With Worksheets("Stands & Displays")
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("a21:a5000")) Is Nothing Then
If Sh.Type = msoPicture Then Sh.Delete
End If
Next Sh
End With
Const Afb_map = "\\C:\Users\WillemsM\OneDrive - elho\2016_packshots ean LR"
myarray = WorksheetFunction.Transpose(Range("b21", Range("b" & Rows.Count).End(xlUp)).Value)
ActiveSheet.Protect False, False, False, False, False
If Not IsArray(myarray) Then Exit Sub
On Error Resume Next
lRow = 21
For lLoop = LBound(myarray) To UBound(myarray)
Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
Cells(2, 1).Left + 19, Cells(lRow, 2).Top + 8, 50, 50)
lRow = lRow + 1
Next lLoop
End Sub