---

grafik.jpg

Hallo Zusammen,
ich bin auf der Suche nach einer Lösung für folgendes Problem. Wir erzeugen immer wieder autoatisch Exceltabellen, siehe Anhang. Gibt es eine Möglichkeit per VBA die Grafiken in dem Textrahmen einzufügen?
Wenn das mit dem Textrahmen nicht geht, würde es schon sehr viel Zeit sparen die Grafiken neben der Nummer zu haben.

Der manuelle Ablauf sieht z.Z. so aus, dass ich die Nummer aus dem Feld B5 in eine Adresse auflöse die lautet: i:\pdf\H11\11001280.jpg
Die Adresse i:\pdf ist immer gleich - dann folgt H11 (die ersten Stellen der Nummer) - dann folgt 11001280 (die Nummer ohne Striche.

Die Grafikadresse des zweiten Bildes (Feld B9) wäre demnach:
i:\pdf\B56\56130111.jpg

Ich danke Euch ....

Viele Grüße aus Hessen

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Martin,
hatte Urlaub, hab mich jetzt aber mal dranbegeben. Ist bestimmt nicht das schönste Projekt auf Erden, aber läuft vielleicht.
Also:
Vorraussetzungen: Dateinamen sind immer gleich aufgebaut:  X11-222-333, die Abstände der Einfügepunkte sind immer 4 Zeilen und die Pfade und Bilder sind vorhanden. Ansonsten ist Anpassen angesagt  
in Spalte A füge ich hilfsweise den Ordnernamen ein, "unter" das Bild, also  in C den Bildnamen. Den Bildnamen sieht man unter dem Bild nicht, und die Spalte A ist weiße Schrift auf weißem Grund. Bei Nichtgefallen könnte man am Ende des Makros die Spalten A und C leeren hab ich mal in Kommentarzeichen gesetzt
Desweiteren müssen evtl. die Bilder größenmäßig angepasst werden, auch dafür ein Ansatz in Kommentarzeichen.

Code:

---

Sub GrafikEinfuegen()
Dim i As Integer
    Columns("A:A").Select
    Selection.Font.ColorIndex = 2
    For i = 5 To 15   Step 4          'Bereich anpassen oder letzten Eintrag suchen lassen
        Cells(i, 1).Select
        ActiveCell.FormulaR1C1 = "=MID(RC[+1],1,3)"
        Cells(i, 3).Select
        ActiveCell.FormulaR1C1 = "=MID(RC[-1],2,2)&MID(RC[-1],5,3)&MID(RC[-1],9,3)"
        Cells(i, 3).Select
        ActiveSheet.Pictures.Insert("I:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select
       
           'Selection.ShapeRange.LockAspectRatio = msoTrue
           'Selection.ShapeRange.Height = 32.25
           'Selection.ShapeRange.Width = 39.75
           'Selection.ShapeRange.Rotation = 0#
    Next
    'Columns("A:A").ClearContents
    'Columns("A:A").Select
    'Selection.Font.ColorIndex = 1
End Sub

---

Kommt zwar spät, aber vielleicht hilft's trotzdem noch.

Gruß,
Nicole

[edit: Kleinigkeiten  ]
------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

[Diese Nachricht wurde von runkelruebe am 28. Jun. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Vielen lieben Dank Nicole!
Wenn Bochum nicht so weit von Hessen wäre, würde ich Dir einen Strauß Blumen bringen - nun, sollst einen bekommen, halt virtuell...

Ich hätte noch drei Fragen an Dich...

1.)
Nach dem Programmablauf kommt ein Laufzeitfehler '1004' - wenn ich auf Debuggen gehe, ist die Zeile:
ActiveSheet.Pictures.Insert("i:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select
gelb markiert.

Das liegt wahrscheinlich an meiner Änderung: For i = 5 To 1000  Step 4          'Bereich anpassen oder letzten Eintrag suchen lassen

Ist zwar nicht schön aber ich kann damit leben.

2.)
Ich habe, wie in der Grafik vom ersten Beitrag zu sehen ist, ein Rechteck in den Zellen C4-C7 gleichmäßig verteilt. Ist es möglich die Bilder genau in dieses Rechteck zu placieren? Die Größe vom Rechteck ist immer 2,8 cm

3.)
Falls ein Bild nicht vorhanden ist, muss das Programm weiter laufen. Zur Zeit bricht es ab. Kann man das irgendwie realisieren?

Nochmals vielen lieben Dank 

Gruß Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Martin!
Vielen Dank für diesen wunderschönen Blumenstrauß! Hab' ich hier noch nie bekommen 

Klar kann man:
Zu 1 und 3:
Zeile einfügen:

Public Sub GrafikEinfuegen
On Error Resume Next
...weiter mit Code
End Sub

Zu 2:
Ich hab die Ansätze ja schon unten im Code stehen.
    'Selection.ShapeRange.LockAspectRatio = msoTrue
    'Selection.ShapeRange.Height = 32.25
    'Selection.ShapeRange.Width = 39.75
    'Selection.ShapeRange.Rotation = 0#
einfach die Hochkomma weg und die Größe anpassen (rumspielen, ich weiß die Umrechnung von Pixel in cm nicht)

Klappt?

Gruß,
Nicole

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Martin,
kleine Änderungen:
- Zellen (B5-B8) und folgende werden zusammengeführt
- das eingefügte Bild ist abhängig von Zellposition und Größe
- es wird mit der Größe 79.5 x 79.5 Pixel eingefügt, sollte ca. 2,8 cm sein
- es wird automatisch der letze Eintrag in Spalte B gesucht
Wenn jetzt alle Zeilen die Höhe 20 haben, sollte hübsch aussehen...tut's zumindest bei mir *g*

Code:

---

Sub GrafikEinfuegen()
On Error Resume Next
Dim i As Integer
'Cells.Select          hier wird die Zeilenhöhe auf 20 festgelegt
'Selection.RowHeight = 20
    For i = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        Cells(i, 1).Select
        ActiveCell.FormulaR1C1 = "=MID(RC[+1],1,3)"
        Cells(i, 3).Select
        ActiveCell.FormulaR1C1 = "=MID(RC[-1],2,2)&MID(RC[-1],5,3)&MID(RC[-1],9,3)"
        Cells(i, 3).Select
        Range(Cells(i, 3), Cells(i + 3, 3)).Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
        Selection.Merge
        ActiveSheet.Pictures.Insert("C:\PDF\" & Cells(i, 1) & "\" & (Cells(i, 3).Value) & ".jpg").Select
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Placement = xlMoveAndSize
                .PrintObject = True
                .ShapeRange.Height = 79.5
                .ShapeRange.Width = 79.5
            End With
    Next
  Columns("A:A").ClearContents
End Sub

---

Da ich den Makro-Recorder benutzt habe, sind da noch einige Sachen unschön, bzw. überflüssig, aber ich wollte es jetzt nicht rauslöschen, vielleicht kann man es ja nutzen für was auch immer

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

ist.jpg soll.jpg

EDIT:
UPS... mein Beitrag ist nicht auf den letzten von Dir bezogen... ich teste erst einmal... 
melde mich dann

---------------------------------------

Hallo Nicole, Danke Dir...
funktioniert soweit einwandfrei - bis auf die Ausrichtung der Bilder. Die Bilder fügen sich immer in der oberen linken Ecke von Zelle C4 - C8 - C12 usw an. Wünschenswert wäre allerdings die obere linke Ecke des Rechtecks welches in Zelle C4 liegt. Ist komisch zu erklären, ich mach dir mal ´ne Grafik.
Danke Dir
Gruß Martin

[Diese Nachricht wurde von Martin_0103 am 28. Jun. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Du willst unbedingt diese Textfelder nutzen, wa?
Kann ich aber auf die Schnelle nicht 
Falls es noch nicht funzt, Lösungsvorschlag: die Bilder nach Einfügen um 5 Pixel nach rechts und 5 Pixel nach unten verschieben natürlich Pixelzahl so anpassen, daß es paßt.:

Code:

---

...
            With Selection
                .ShapeRange.LockAspectRatio = msoFalse
                .Placement = xlMoveAndSize
                .PrintObject = True
                .ShapeRange.Height = 79.5
                .ShapeRange.Width = 79.5
                .ShapeRange.IncrementLeft 5#  'hier wird verschoben
                .ShapeRange.IncrementTop 5#
            End With
...

---

------------------
Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Nicole...
bin ich schwer zufrieden zu stellen? 

Du, es läuft zu meiner vollsten Zufriedenheit... ich kann mich nur nochmals bei Dir bedanken!!! Hast mir sehr geholfen - vorallem in welch einer Zeit! Klasse!

Lieben Gruß 

Martin   

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

und nun das ganze ohne Vba 

gruss Thomas *bin heut blöd drauf*

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Forum,
ich stell hier das Makro nochmals mit zwei kleinen Änderungswünschen ein.
Seinerzeit sind wir von immer der gleichen Struktur der Nummern ausgegangen  ->  X11-222-333
daraus wurde der Bildername  ->  11222333.jpg
Nun ist ein Kollege auf die tolle Idee gekommen, eine zusätzliche neue Nummer zu kreieren -> X11-222-333-4
daraus wird dann der Bildname  ->  11222333-4.jpg

Änderungswunsch 1
Nun die Bitte, ist es möglich eine solche Änderung in dem Makro zu berücksichtigen? Für mich sind das böhmische Dörfer... Hut ab vor denen die das können und vor denen die hier helfen!!!

Hier das Makro:

Sub GrafikEinfuegen3()
    Dim intIndex As Integer, strPfad As String, shpRectangle As Shape
    On Error GoTo err_exit
    For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _
            Mid$(Replace(Cells(intIndex, 2).Value, "-", ""), 2) & ".jpg")
        With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3))
            Set shpRectangle = ActiveSheet.Shapes.AddShape( _
                msoShapeRectangle, .Left, .Top, .Width, .Height)
        End With
        shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad
    Next
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

Public Sub BilderLoeschen3()
    Dim sh As Object
    On Error GoTo err_exit

    For Each sh In ActiveSheet.Shapes
        If sh.Type = msoShapeRectangle Then
            sh.Select
                With Selection
                    .ShapeRange.Fill.Visible = msoFalse
                End With
        End If
    Next
    Exit Sub
err_exit:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
End Sub

Änderungswunsch 2 oder besser zusätzliches Makro
Ich würde ein Makro benötigen welches ich in Excel, Word oder auch Outlook per Button starten kann welches wie folgt arbeitet.

Es sollte ein Fragefenster "Grafik einfügen" aufgehen in das ich die Nummer X11-222-333 oder die Nummer X11-222-333-4 manuell eingebe. Mit der Bestätigung eines OK Buttons sollte die Grafik an der Cursorposition eingefügt werden (analog des o.s. Makros). Die Grafik kann ich dann mittels Maus positionieren.

Vielen lieben Dank

Gruß Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

zu 1 -

Code:

---

strPfad = ("i:\PDF\" & Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")

---

und zu 2 Aktive Zelle ist dort wo das Bild eingefügt werden soll

Code:

---

sTxt = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", Replace(ActiveCell.Offset(0, -1), "-", "", , 2))

---

könnte eine Lösung sein

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Matthias,

zu 1.:

Folgende Zeile austauschen:  

Code:

---

For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _
            Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")

---

Erklärung: ich ersetze nur noch 2 Stück Bindestriche:

Replace(Cells(intIndex, 2).Value, "-", "", , 2)

hier ist es die letzte 2, die die Anzahl der zu ersetzenden Zeichen bestimmt.

Zu Deinem 2. Problem: Stichwort ist (glaub ich) TextBox, da gibt es aber noch was zweites, der Begriff ist mir spotan entfallen  
Ich melde mich wieder, muß noch schaffen...

[edit] ach guck mal, da war schon jemand... Hallo Thomas! : )[/edit]

------------------
Gruß,
Nicole                          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

[Diese Nachricht wurde von runkelruebe am 27. Okt. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

ohne das jetzt mit dem Bildeinfügen geprüft zu haben -keine Lust mir so ein Verz. samt Bild zu erstellen :-)

zu 1

Code:

---

Sub GrafikEinfuegen3()
    Dim intIndex As Integer, strPfad As String, shpRectangle As Shape
    On Error GoTo err_exit
    For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        strPfad = ("i:\PDF\" & Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")
        strPfad = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", strPfad) 'optional
        With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3))
            Set shpRectangle = ActiveSheet.Shapes.AddShape( _
                msoShapeRectangle, .Left, .Top, .Width, .Height)
        End With
        shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad
    Next
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

und zu 2 Aufruf am besten über Tastenkürzel oder auch Button und makrozuweisen

Code:

---

Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer
    Dim intIndex As Integer, strPfad As String, shpRectangle As Shape
    On Error GoTo err_exit
   
    strPfad = InputBox("Bitte Eingabe tätigen:", "Grafik einfügen", _
    "i:\PDF\" & Mid$(Replace(ActiveCell.Offset(0, -1), "-", "", , 2), 2) & ".jpg")
        With Range(ActiveCell, ActiveCell.Offset(3, 0))
            Set shpRectangle = ActiveSheet.Shapes.AddShape( _
                msoShapeRectangle, .Left, .Top, .Width, .Height)
        End With
        shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad
 
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Nicole, Hallo Thomas,
vielen Dank für Eure Hilfe. Allerdings komm ich nicht ganz klar damit, die Änderung von Nicole:

Zitat:

---

Code:

For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        strPfad = ("i:\PDF\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _
            Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")

---

arbeitet unerwartend, d.h. es wird ein Rahmen eingefügt - allerdings tiefer als bei dem original Makro dafür aber "ohne" Bild.

Das Makro von Thomas verlangt eine Eingabe? Dieses sollte nicht sein, es sollte schon automatisch ablaufen.

Der Änderungswunsch ist:
X11-222-333      ->  11222333.jpg
X11-222-333-4    ->  11222333-4.jpg

Beide Varianten kommen vor!

Der Vorschlag von Thomas bezüglich dem 2. Wunsch geht soweit - jedoch wird kein Bild eingefügt! Evtl. hängt das an o.g. Problem!

Vielleicht habt ihr ja noch mal Zeit es anzuschauen.

Vielen Dank
Gruß Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Martin,
ich hab's jetzt nicht wieder komplett nachgestellt (so mit Anlegen von nem "PDF"-Ordner und mit den Bildern drin und so...), aber da wir ja nur eine Zeile verändert haben, müßte es eigentlich laufen.
Vorausgesetzt natürlich, daß die Pfad-Angaben immer noch : Ordner "PDF" auf Laufwerk "I", und die Bilder sind da auch tatsächlich drin!

Das mit dem eine Zeile tiefer liegt am Schleifenstart:
For intIndex = 5 To Cells(Rows.Count, 2).End(xlUp).Row Step 4

hier hab ich Dir versehentlich die Zeile vermurkst  , schreib anstatt 5 mal wieder ne 4 hin, dann paßt das Rechteck wieder 

Prüf doch mal mit dieser kleinen Änderung nochmal, und kontrolliere, ob die Ordnerstruktur vorhanden und gefüllt ist und wenn's wirklich nicht geht, dann stell' ich's mir heute nachmittag auch gerne nochmal nach.

Bis dahin!

------------------
Gruß,
Nicole                          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Nicole,
kleine Unterschiede, große Wirkung 
Es lag an der 5 !

Das Makro funktioniert!

Vielen vielen Dank
Gruß Martin

PS: leider finde ich diese 5 nicht bei dem anderen Makro 

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Prima.

und zu 2.: Versuch mal dieses leicht geänderte:

Code:

---

Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer
    Dim intIndex As Integer, strPfad2 As String, shpRectangle As Shape
    On Error GoTo err_exit
   
   strPfad2 = "i:\PDF\" & InputBox("Bitte Eingabe tätigen:", "Grafik einfügen") & ".jpg"

        With Range(ActiveCell, ActiveCell.Offset(3, 0))
       
            Set shpRectangle = ActiveSheet.Shapes.AddShape( _
                msoShapeRectangle, .Left, .Top, .Width, .Height)
        End With
        shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad2
 
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

in die Eingabeaufforderung jetzt nur noch die Bildnummer reinschreiben: Bsp: 111222333-4
das "I\PDF\" und das ".jpg" drumrum werden automatisch eingefügt.

------------------
Gruß,
Nicole                          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

[wie immer: wenn man schon 'nen VariablenNamen ändert, dann bitte auch überall     ]

[Diese Nachricht wurde von runkelruebe am 30. Okt. 2006 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

bef.jpg

Hallo Nicole,
geht noch nicht. Das Resultat sieht wie auf der Grafik aus. Der Bildrahmen wird der Zelle angepaßt!

Der Aufruf müßte meines Erachtens mit der vollen Nummer realisiert werden - sonst weiß man den Dateiordner nicht.

H11-002-206  ->  Ordner:  i:\pdf\H11\11002206.jpg

oder

H11-002-206-1  ->  Ordner:  i:\pdf\H11\11002206-1.jpg

Vielen Dank

Gruß Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

dieses H11 kann er sich aber nirgendwoher ziehen, also müßtest Du es mit eingeben:  Eingabe = H11\111222333-4
dann müßte es gehen.

zum Rechteck: das ist abhängig von der Zelle, in der Du beim Makro-Aufruf stehst und doch auch so gewollt!?

Zitat:

---

Die Grafik kann ich dann mittels Maus positionieren.

---

OK, am Mauszeiger wird es noch nicht eingefügt, aber das können wir auch anders haben, ohne Rechteck, nur die Grafik einfügen:

Code:

---

Sub Grafikinput() 'Manuell - Aktive Zelle ist rechts der Nummer
    Dim intIndex As Integer, strPfad3 As String, shpRectangle As Shape
    On Error GoTo err_exit
   
  strPfad3 = "i:\PDF\" & InputBox("Bitte Eingabe tätigen:", "Grafik einfügen") & ".jpg"
        ActiveSheet.Pictures.Insert(strPfad3).Select
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

check es und berichte 

------------------
Gruß,
Nicole                          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Nicole,
super Sache, es funktioniert...!!!
Danke Dir!
Ganz lieben Gruß aus Hessen
Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo liebes Forum,

dieser Code scheint, als sei er genau dass, was ich gesucht habe...
Nur leider habe ich was VBA angeht überhaupt keine Ahnung, wie ich den Code eingeben muß, und vor allem, welche Zellen für den Dateinnamen stehen...

Mein Wunsch wäre folgendes:
Eine Zelle (Dropdownfeld, Tabellenname: Auswahl, Zelle:C1) zur Auswahl des Dateinamens. Der Dateiname ist gleich der Artikelnr.
Der Pfad: H:\Produktbilder\    dateiformat bleibt jpg.

Die Bildaktualisierung sollte nach Auswahl durch das Dropdownfeld erfolgen (nur wenn das geht...)

Und wenn es geht, vielleicht eine kleine Anleitung, wie ich den Code einfügen muß, damit es funktioniert.

Es wäre mir eine große Hilfe...

Danke im Voraus,

Andreas

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

2013-04-09-VBA-wohin-damit.PNG

Moin Andreas,

vorab: gar keine Ahnung von VBA ist viel zu wenig Ahnung von VBA ;-)
Änder das, Tutorialempfehlungen findest Du u.a.hier im Forum.

Zitat:

---

Original erstellt von scrarat:
Mein Wunsch wäre folgendes:
Eine Zelle (Dropdownfeld, Tabellenname: Auswahl, Zelle:C1) zur Auswahl des Dateinamens. Der Dateiname ist gleich der Artikelnr.
Der Pfad: H:\Produktbilder\    dateiformat bleibt jpg.

Die Bildaktualisierung sollte nach Auswahl durch das Dropdownfeld erfolgen (nur wenn das geht...)

---

In diesem (steinalten  ) thread ging es bislang darum, eine ganze Reihe von Bildern einzufügen, daher auch die Schleifen drumrum.

Wenn ich Deine Anfrage richtig deute, suchst Du was ganz anderes, ein einfaches:

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPfad7$
'Nur Änderungen von C1 sind interessant, daher aus Performancegründen Bereich einschränken!
If Not Intersect(Target, Range("C1")) Is Nothing Then
    strPfad7 = " H:\Produktbilder\ " & (ActiveCell.Value) & ".jpg"
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Pictures.Insert (strPfad7)
End If
End Sub

---

sollte Dir laut Beschreibung schon reichen.

Einfügen musst Du diesen kompletten Code im Bereich des worksheets, auf dem die Sache stattfinden soll, siehe angehängten screenshot.

Das Dropdown hast Du doch hoffentlich schon? Wenn nicht: (Angaben für Excel2010, bitte Systeminfo ergänzen)
Ribbon: Daten > Gruppe: Datentools > Befehl: Datenüberprüfung > Zulassen: Liste > Quelle: an- oder eingeben [ =$A$1:$A$3 oder rot;gelb;blau ]

HTH 

------------------
Gruß,
runkelruebe          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi @All,

nur mal als Tipp am Rande: wenn man nur 1 Adresse überwachen möchte, benötigt man kein Intersect, da reicht die Zelladresse

Code:

---

If Target.Address = "$C$1" Then

---

Wichtig dabei - die Adresse muss absolut angegeben sein. Will man die Adresse (obwohl dazu keine Notwendigkeit besteht) unbedingt relativ angeben, geht das mit einem Zusatz ebenfalls

Code:

---

If Target.Address(False, False) = "C1"

---

------------------
Bis später,
Karin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Forum,
nun haben wir nach langer Zeit auf Excel 2010 umgestellt und siehe da, das Makro läuft nicht mehr. Wäre schön, wenn wir das wieder zum Laufen bringen würden.
Vielen Dank schon mal
Gruß Martin

Code:

---

Sub GrafikEinfuegen3()
    Dim intIndex As Integer, strPfad As String, shpRectangle As Shape
    On Error GoTo err_exit
    For intIndex = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 4
        strPfad = ("i:\PDF\KVD\" & Split(Cells(intIndex, 2).Value, "-")(0) & "\" & _
            Mid$(Replace(Cells(intIndex, 2).Value, "-", "", , 2), 2) & ".jpg")
        With Range(Cells(intIndex, 3), Cells(intIndex + 3, 3))
            Set shpRectangle = ActiveSheet.Shapes.AddShape( _
                msoShapeRectangle, .Left, .Top, .Width, .Height)
        End With
        shpRectangle.OLEFormat.Object.ShapeRange.Fill.UserPicture strPfad
    Next
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

------------------
Wenn man einen Hund so dressiert hat, dass er über einen See fliegt, dann gibt es sicher ein paar Neider die das Tier für Wasserscheu halten...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Excelliste.pdf

Hallo Nicole,
ich schaffe es einfach nicht das Makro richtig abzuändern.

Ich habe einen Excelliste (Exc.2007)siehe Anlage und möchte die Bilder dazu automatisch einfügen.

Der Artikelpfad steht in Spalte I (mehrfach)- Das Bild soll in Spalte
J eingefügt werden - Bildgrösse ca. 3 cm. Immer beginnend am zuerst
genannten Bildpfad.

Der Bildpfad ist:

F:\Muster\FS2015\Niedrig\20522_501.jpg

F:\Muster\bleibt immer gleich alle anderen Angaben ändern sich im Pfad.

mfg
Klaus

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

picinComment.zip

Es ist egal ob >F:\Muster< immer gleich bleibt, wenn die volle Adressierung in den Zeilen der Spalte I geben ist.

Da nicht bekannt ist welche Variante vom Code man anpassen will, gibt es halt mal eine Variante im Kommentar     

Klarer Input -klarer Output

Code:

---

Sub picincomm()

    Dim intIndex As Integer, strPfad As String, shpRectangle As Shape
    On Error GoTo err_exit
    For intIndex = 2 To Cells(Rows.Count, 9).End(xlUp).Row Step 1  '= Spalte I
        strPfad = Cells(intIndex, 9)

If Not Cells(intIndex, 10).Comment Is Nothing Then
                Cells(intIndex, 10).Comment.Delete
            End If
    Cells(intIndex, 10).AddComment
    Set objCom = Cells(intIndex, 10).Comment.Shape
    With objCom
        .Fill.UserPicture strPfad
        .Width = 100
        .Height = 100
    End With

    Next
    Exit Sub
err_exit:
'    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung"
        Resume Next
End Sub

---

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Welchen Code benutzt Du?
poste ihn doch mal ...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Guten Tag KlaK,

ich habe keinen Code - ich habe mit den oben genannten Formeln
ausprobiert.
Leider habe ich wenig bis keine Ahnung von Makros.
Ich hoffe aus Hilfe

mfg
Klaus

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zitat:

---

Original erstellt von KlausReiff:
ich habe keinen Code - ich habe mit den oben genannten Formeln
ausprobiert.

---

Du hast die Codeschnippsel als Formel eingegeben?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Thomas

ja habe ich - Leider ohne Erfolg.Kannst du mir mit einem entsprechenden
Makro weiterhelfen ?

mfg
Klaus

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

< Die codeschnippsel sind keine formeln, sonden schon entsprechende codes für ein makro >

Ein bsp. wäre ja in der gezippten Datei Picincomment vorhanden.

Datei entpacken,
die Datei mit Excel öffen,
die Bsp. Pfade anpassen
und auf den Schalter >Klick mich< drücken

sollte in der nebenstehenden Spalte die Bilder in das Kommentarfeld verfrachten.

Aber dies ist ja nur ein Bsp.

Deine genaue Aufgabenstellung ist nicht bekannt:
- vollautomatisch
- oder nur selektiv
- oder gar als neue Funktion aka = Bild(F2)

und da du die Codeschnippsel als Formel eingegeben hast...
muss man ganz von vorn anfangen - was ist Excel, Formeln und was ist ein Makro -

weil schliesslich musst du es ja bedienen können und ggf. auch wissen was passiert um es vielleicht irgendwann anzupassen ;-)

Es Bringt nicht viel, wenn wir dir ein Code erstellen und du weisst nicht wo und wohin mit dem Code  - (Alt&F11) VBA Umgebung)
Ebensowenig wenn du einen Bsp Code nicht für deine Bedürfnisse anpassen kannst.

Daher Klarer Input - Was genau ist die Aufgbenstellung, ggf. mit Bsp-Excel-Mappe (sensible Daten durch Dummy Werte ersetzen)
Damit macht man es den Helfenden etwas einfacher.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP