VBA/ Makro Arbeitsmappe Bild zuordnen
24.02.2014 11:05:53
min
habe einen VBA-Code, um zugeordnete Bilder aus einem anderen Tabellenblatt in ein aktives Tabellenblatt einzufügen, wenn in einer Zelle ein Wert eingetragen wird. Da es aber viele Tabellenblätter geben wird, würde ich gern den VBA-Code nicht in jedem Tabellenblatt hinterlegen wollen, sondern in der gesamten Arbeitsmappe als Makro. Wie muss der Code dann verändert werden?
Der Code der einzelnen Tabellenblättern schaut nun so aus und funktioniert so:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oldCell
oldCell = ActiveCell.Address
If Not IsEmpty(Target) Then
Dim iAdd, Art As String
With Sheets("PL")
iAdd = Cells(Target.Row, 2).Address
Art = Left(Cells(Target.Row, 4), 2)
Set a = .Columns(2).Find(What:=Art & "*", LookIn:=xlValues, LookAt:=xlWhole)
If Not a Is Nothing Then iAd = a.Row
For Each Bild In .Shapes
If Bild.TopLeftCell.Address = "$G$" & iAd Then
Bild.Copy
ActiveSheet.Paste Range(iAdd)
Rows(Target.Row).RowHeight = 40
Selection.ShapeRange.IncrementLeft 2.25
Selection.ShapeRange.IncrementTop 2.25
End If
Next
End With
Else
iAdd = Cells(Target.Row, 2).Address
For Each Bild In ActiveSheet.Shapes
If Bild.TopLeftCell.Address = iAdd Then
Bild.Delete
Rows(Target.Row).RowHeight = 15
End If
Next
End If
Range(oldCell).Select
End Sub
für jedes Tabellenblatt:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 6 Then
Makro
End If
End Sub
für das Modul:
Sub Makro()
Dim oldCell
oldCell = ActiveCell.Address
' Bild suchen kopieren und einfügen
If Not IsEmpty(Target) Then
Dim iAdd, Art As String
With Sheets("PL")
iAdd = Cells(Target.Row, 2).Address
Art = Left(Cells(Target.Row, 4), 2)
Set a = .Columns(2).Find(What:=Art & "*", LookIn:=xlValues, LookAt:=xlWhole)
If Not a Is Nothing Then iAd = a.Row
For Each Bild In .Shapes
If Bild.TopLeftCell.Address = "$G$" & iAd Then
Bild.Copy
ActiveSheet.Paste Range(iAdd)
Rows(Target.Row).RowHeight = 40
Selection.ShapeRange.IncrementLeft 2.25
Selection.ShapeRange.IncrementTop 2.25
End If
Next
End With
Else
' Bild löschen
iAdd = Cells(Target.Row, 2).Address '>> bleibt hier hängen
For Each Bild In ActiveSheet.Shapes
If Bild.TopLeftCell.Address = iAdd Then
Bild.Delete
Rows(Target.Row).RowHeight = 15
End If
Next
End If
Range(oldCell).Select
End Sub Hier die Datei dazu:
https://www.herber.de/bbs/user/89400.xlsm
Könnte sich das jemand nochmal ansehen, das wäre toll?!?
Danke & Grüße
min