wenn Eingabe, dann def. Bild aus anderem Sheet

Hallo zusammen,
in einer Stücklisten-Datei mit zig (über 30) Tabellenblättern sollen Bilder eingefügt/ angezeigt werden, wenn einzelne Artikel mit einer Stückzahl größer 0 ausgewählt werden. D.h. es gibt mind. drei Spalten: Anzeige Bild + Kurzbezeichnung + Stückzahl.
Dazu gibt es ein Tabellenblatt, das für die Anwender ausgeblendet wird, in dem alle Artikel mit Kurzbezeichnung etc. und dem jeweiligen Bild abgelegt/ gesammelt sind, auf das alle anderen zugreifen.
Muss jedes Bild einzeln abgelegt und mit der eindeutigen Kurzbezeichnung benannt werden (über das Namenfeld bezeichnen?)? Oder können die Artikel "SD 12", "SD 16" und "SD 20" alle auf das "BildSD" zugreifen?
Im Anhang ist eine Datei, die das bisher so macht, dass die Bilder ein- und ausgeblendet werden via VBA innerhalb eines Tabellenblatts. Nun kommt die Anforderung dazu, dass nicht alle Tabellenblätter einzeln gepflegt werden müssen, sondern ein einziges und alle sich darauf beziehen.
(hab das bisherige Tabellenblatt gelb gemacht und die neuen/ künftigen beide in rot, gelb und rot haben nichts miteinander zu tun später)
https://www.herber.de/bbs/user/89246.xlsm
Wäre super, wenn mir jemand diese Frage(n) beantworten könnte...
Danke!!
min

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo hell ActiveSheet.Shapes.Range(Array("Bild" & OldRow)).Visible = Not (Cells(OldRow, 8).Value = "") Rows(OldRow).RowHeight = IIf(Cells(OldRow, 5).Value = "", 18, 40) hell: End Sub

Private Sub Worksheet_Change(ByVal Target As Range) ' Bild suchen kopieren und einfügen If Not IsEmpty(Target) Then Dim iAdd, Art As String With Sheets("ausgeblendeter Hintergrund") iAdd = Cells(Target.Row, 2).Address Art = Left(Cells(Target.Row, 3), 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 = "$E$" & iAd Then Bild.Copy Sheets("SOLL").Paste Range(iAdd) Rows(Target.Row).RowHeight = 40 Selection.ShapeRange.IncrementLeft 14.25 Selection.ShapeRange.IncrementTop 2.25 End If Next End With Else ' Bild löschen iAdd = Cells(Target.Row, 2).Address For Each Bild In Sheets("SOLL").Shapes If Bild.TopLeftCell.Address = iAdd Then Bild.Delete Rows(Target.Row).RowHeight = 15 End If Next End If End Sub

Hallo Beni,
vielen Dank für deine Antwort!!!!!
Der Code schaut nun so aus (SOLL ersetzt gegen ActiveSheet und aktive Zelle nach Eingabe nächste Zeile):

Private Sub Worksheet_Change(ByVal Target As Range)
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
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

Gibt es eine Möglichkeit, dass dieser Code als Makro bzw. Modul für eine ganze Arbeitsmappe mit x Tabellenblättern gilt, sodass der Pflegeaufwand nur einmalig ist?
Das hab ich probiert, läuft aber nicht ganz durch:
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
https://www.herber.de/bbs/user/89336.xlsm
Grüße
min

Beliebteste Forumthreads (12 Monate)

wenn Eingabe, dann def. Bild aus anderem Sheet

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

wenn Eingabe, dann def. Bild aus anderem Sheet

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread