VBA: Fehler 13 & 1004

[Webinho]

Hallo,

ich sitze an einer Tabelle die nach Eingabe einer Nummer Bilder einfügt.
Vom Prinzip hab ich das Ganze mit meinen quasi nicht vorhandenen VBA-Kenntnissen auch hinbekommen, leider gibt es aber noch einige Fehler/Schwachstellen die ich gerne ausbügeln würde.

Grobes Prinzip: Man kann in die Zellen B3:B6 eine Zeichenkombination eingeben wodurch im Tabellenblatt die zugehörigen Bilder an bestimmten Positionen eingefügt werden (die jeweiligen Bildlinks holt sich das Makro aus den Zellen D1:G1).
Soweit so gut, das habe ich mit 2 Modulen hinbekommen.

Nun aber treten folgende Fehler auf:

-Schreibt man etwas in die Zellen B3:B6, wird der Fehler 13 gemeldet ("Typen unverträglich")
Nach beenden des Debuggers und erneuter Eingabe wird das Bild dann allerdings eingefügt.
-Löscht man einen der Einträge aus B3:B6, kommt Laufzeitfehler 1004 ("Die Insert-Eigenschaft des Picture-Objects kann nicht zugeordnetet werden")
-Sind beispielsweise die Felder B3:B5 schon ausgefüllt und man fügt etwas in B6 ein wird jedes Bild viermal eingefügt.

Wünschenswert wäre es zusätzlich, dass die Bilder gelöscht werden, sobald in der jeweiligen B3:B6-Zelle nichts steht. Ich habe gelesen dass sowas prinzipiell mit "ActiveSheet.Pictures.Delete" möglich ist - habe aber keine Ahnung wo und wie ich das in meine Makros einbauen müsste.

Ich habe mal beispielhaft eine kleine Mappe angefügt, in der das Prinzip deutlich wird.
Hier noch die beiden Makros als Text:

Steht direkt in der Tabelle:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target = Range("G2") Then Call Bildvariabel
If Target = Range("G3") Then Call Bildvariabel
If Target = Range("G4") Then Call Bildvariabel
If Target = Range("G5") Then Call Bildvariabel

End Sub

Als Modul:

Sub Bildvariabel()

Dim url
Dim urla
Dim urlb
Dim urlc

Sheets("Start").Select
url = Range("D1").Value
urla = Range("E1").Value
urlb = Range("F1").Value
urlc = Range("G1").Value

ActiveSheet.Pictures.Insert(url).Select
With Selection
.top = Range("B13").top
.left = Range("B13").left
.Width = Range("A1:O1").Width
.height = .Width * 3 / 3

End With

ActiveSheet.Pictures.Insert(urla).Select
With Selection
.top = Range("X13").top
.left = Range("X13").left
.Width = Range("A1:O1").Width
.height = .Width * 3 / 3

End With

ActiveSheet.Pictures.Insert(urlb).Select
With Selection
.top = Range("B61").top
.left = Range("B61").left
.Width = Range("A1:O1").Width
.height = .Width * 3 / 3

End With

ActiveSheet.Pictures.Insert(urlc).Select
With Selection
.top = Range("X61").top
.left = Range("X61").left
.Width = Range("A1:O1").Width
.height = .Width * 3 / 3

End With

End Sub

PS: Excel-Version 2003

[Steffl]

Hallo,

mal ungetestet ohne das meist überflüssige Selektieren

Code:

Sub Bildvariabel()
   Dim wksSheet As Worksheet
   Dim url
   Dim urla
   Dim urlb
   Dim urlc
  
   Set wksSheet = Workheets("Start")
   With wksSheet
      url = .Range("D1").Value
      urla = .Range("E1").Value
      urlb = .Range("F1").Value
      urlc = .Range("G1").Value
      
      With .Pictures.Insert(url)
         .Top = wksSheet.Range("B13").Top
         .Left = wksSheet.Range("B13").Left
         .Width = wksSheet.Range("A1:O1").Width
         .Height = .Width * 3 / 3
      End With
      
      With .Pictures.Insert(urla)
         .Top = Range("X13").Top
         .Left = Range("X13").Left
         .Width = Range("A1:O1").Width
         .Height = .Width * 3 / 3
      End With
      
      With .Pictures.Insert(urlb)
         .Top = wksSheet.Range("B61").Top
         .Left = wksSheet.Range("B61").Left
         .Width = wksSheet.Range("A1:O1").Width
         .Height = .Width * 3 / 3
      End With
      
      With .Pictures.Insert(urlc)
         .Top = wksSheet.Range("X61").Top
         .Left = wksSheet.Range("X61").Left
         .Width = wksSheet.Range("A1:O1").Width
         .Height = .Width * 3 / 3
      End With
   End With
End Sub

[Webinho]

Hallo Steffl,

vielen Dank für die schnelle Antwort. Dein Code sieht definitiv schonmal deutlich "sauberer" aus als bei mir :D

Es hat sich so zumindest das Problem erledigt, dass bei der beispielsweise 4. Eingabe die anderen auch Bilder auch 4 mal neu geladen werden. Das Hauptproblem - dass dort wirklich nur die Bilder zu sehen sein sollen deren zugehörige Zeichenkombination gerade in B3:B6 steht (und vor allem dass auch das Bild gelöscht werden sollte, falls nix in der jeweiligen Zelle steht!) - liegt allerdings leider immernoch vor. Zudem erscheint nach wie vor der Fehler 1004 sobald man eine Zeichenkombination aus B wieder löscht. Trotzdem vielen Dank für deine Mühen!

[Steffl]

Hallo,

dein Change-Code ginge auch kürzer

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("B3:B6")) Is Nothing Then Call Bildvariabel

End Sub

und der andere

Code:

Sub Bildvariabel()
   Dim wksSheet As Worksheet
   Dim url
   Dim urla
   Dim urlb
   Dim urlc
  
   Set wksSheet = Worksheets("Start")
   With wksSheet
      .Pictures.Delete
      url = .Range("D1").Value
      urla = .Range("E1").Value
      urlb = .Range("F1").Value
      urlc = .Range("G1").Value
      
      If url <> "" Then
         With .Pictures.Insert(url)
            .Top = wksSheet.Range("B13").Top
            .Left = wksSheet.Range("B13").Left
            .Width = wksSheet.Range("A1:O1").Width
            .Height = .Width * 3 / 3
         End With
      End If
      If urla <> "" Then
         With .Pictures.Insert(urla)
            .Top = Range("X13").Top
            .Left = Range("X13").Left
            .Width = Range("A1:O1").Width
            .Height = .Width * 3 / 3
         End With
      End If
      If urlb <> "" Then
         With .Pictures.Insert(urlb)
            .Top = wksSheet.Range("B61").Top
            .Left = wksSheet.Range("B61").Left
            .Width = wksSheet.Range("A1:O1").Width
            .Height = .Width * 3 / 3
         End With
      End If
      If urlc <> "" Then
         With .Pictures.Insert(urlc)
            .Top = wksSheet.Range("X61").Top
            .Left = wksSheet.Range("X61").Left
            .Width = wksSheet.Range("A1:O1").Width
            .Height = .Width * 3 / 3
         End With
      End If
   End With
End Sub

[Webinho]

Bist du ein Gott oder bist du ein Gott?

Fantastisch! Funktioniert 1A!
Tausend Dank

[Webinho]

Ein letztes noch: Das Ganze funktioniert perfekt, aber nicht wenn das Arbeitsblatt gesperrt ist die (Eingabezellen sind natürlich nicht gesperrt.)
Hast du dafür auch ne Lösung?

[Steffl]

Hallo,

entsperre das Tabellenblatt. Ich habe übrigens den Code nochmals geändert (leider gibt es auf diesem Rechner eine Fehlermeldung)

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("B3:B6")) Is Nothing Then Call Bildvariabel(Target.Cells(1))

End Sub

Code:

Sub Bildvariabel(rngZiel As Range)
   Dim wksSheet As Worksheet
   Dim vntBereich As Variant
    
   vntBereich = Array("B13", "X13", "B61", "X61")
   Set wksSheet = Worksheets("Start")
   With wksSheet
      .Unprotect Password:="Dein Passwort"   'Bitte anpassen
      If rngZiel.Value <> "" Then
         With .Pictures.Insert(WorksheetFunction.Index(wksSheet.Range("D1:G1"), rngZiel.Row - 2))
            .Top = wksSheet.Range(vntBereich(rngZiel.Row - 3)).Top
            .Left = wksSheet.Range(vntBereich(rngZiel.Row - 3)).Left
            .Width = wksSheet.Range("A1:O1").Width
            .Height = .Width * 3 / 3
         End With
      Else
         .Pictures.Range(vntBereich(rngZiel.Row - 3)).Delete
      End If
      .Protect Password:="Dein Passwort"   'Bitte anpassen
   End With
End Sub