VBA Shape löschen und einfügen
13.10.2021 11:18:01
Vogl
Ich habe eine Datei, wo ich auf einem Tabellenblatt 2 Links habe Link1 und Link2.
Diese sollen durch das auswählen eines anderen KFZ gelöscht werden, und dann von dem Tabellenblatt des KFZ wieder eingefügt werden.
Wenn ich die Shapes lösche und wieder einfüge ist kein Shape mehr da, wenn dích dies rauskommentiere funktioniert es en paar mal, aber dann habe ich mehrere Shapes da. Die shapes sollen mit Links zu Berichten bzw Fotos verlinkt werden, und sollten daher vom richtigen KFZ sein.
Private Sub OKButton_Click()
'altes Löschen
Dim KFZohne As Variant
KFZohne = Cells(5, 4).Value
If KFZohne = "" Then
ActiveSheet.Shapes("Muster").Visible = True
Else
Sheets("Abfrage").Select
ActiveSheet.Shapes.Range(Array(KFZohne)).Select
Selection.Delete
Sheets("Abfrage").Select
ActiveSheet.Cells(5, 2).Select
Selection.ClearContents
ActiveSheet.Shapes("Muster").Visible = False
End If
'** Neues benanntes Tabellenblatt einfügen
'** einfügen als letztes Blatt
'** Dimensionierung der Variablen
Dim blatt As Object
Dim BlattName As String
Dim bolFlg As Boolean
'** Blattname festlegen
BlattName = ListFahrzeuge
'** Prüfen, ob das Blatt, welches eingefügt werden soll bereits vorhanden ist
'** Nur einfügen, wenn Blatt noch nicht vorhanden ist
For Each blatt In Sheets
If blatt.Name = BlattName Then bolFlg = True
Next blatt
'** Blatt nur einfügen, wenn noch nicht vorhanden
If bolFlg = False Then
With ThisWorkbook
Worksheets("Muster").Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = ListFahrzeuge
Range("L17").Value = ListFahrzeuge
Sheets(BlattName).Select
End With
Else
Sheets("Abfrage").Select
ActiveSheet.Range("B5").Select
Range("B5").Value = BlattName
Dim KFZohne2 As Variant
Dim KFZ As Variant
KFZohne2 = Cells(5, 4).Value
KFZ = Cells(5, 2).Value
Sheets("Abfrage").Select
ActiveSheet.Shapes("Muster").Visible = False
Sheets(BlattName).Select
ActiveSheet.Shapes.Range(Array(KFZohne2)).Select
Selection.Copy
Sheets("Abfrage").Select
ActiveSheet.Range("K11").Select
ActiveSheet.Paste
Sheets(KFZ).Select
ActiveSheet.Range("M26:M32").Select
Selection.Copy
Sheets("Abfrage").Select
ActiveSheet.Range("N28:N34").Select
ActiveSheet.Paste
' Sheets("Abfrage").Select
' ActiveSheet.Shapes.Range("Link1").Select
' Selection.Cut
Sheets(KFZ).Select
ActiveSheet.Shapes("Link1").Copy
Sheets("Abfrage").Select
ActiveSheet.Range("O28").Select
ActiveSheet.Paste
' Sheets("Abfrage").Select
' ActiveSheet.Shapes.Range("Link2").Select
' Selection.Cut
Sheets(KFZ).Select
ActiveSheet.Shapes("Link2").Copy
Sheets("Abfrage").Select
ActiveSheet.Range("R24").Select
ActiveSheet.Paste
End If
UFEingabe.Hide
Unload UFEingabe
End Sub