Bilder einfügen

[Steffen20]

Ich habe die Aufgabe über 1000 Bilder einfügen. Pro Blatt wird immer ein 1  Bild hinzugefügt. Jedes Blatt hat seinen Überschrift. Der Überschrift pro Blatt ändert sich minimal.

Am ende werden es über 100 Exceldokumente die jeweils mindestens 10-15 Blätter haben werden.

Ich würde gerne eine Excel Vorlage erstellen und anhand dieses nur die Bilder ändern und die Überschrift minimal anzupassen.

DIe Excelfunktion "bild ändern" ist sehr schlecht da es sehr zeitaufwendig ist.

Gibt es irgendwelche Möglichkeit das alles mit einem Skript zu machen? Wo ich einfach den Pfad des Bildes jeweils ändern kann und so nicht soviel Zeit verlieren?

Leider habe ich null Kenntnisse in VBA. Habt ihr eine Vorlage für mich veilleicht?

Vielen Dank!

Gruß Steffen

[Fennek]

Hallo Steffen,

könntest Du eine kleine Beispieldatei hochladen und folgende Fragen beantworten:

- wie werden Texte und Bilder zugeordnet
- sollen die Bilder bei Eingabe der Text eingefügt werden, oder werden die Bilder in die Dateien mit dem fertigen Text eingefügt
- wie ändern sich die Überschriften

Mache Dich mit den Grundlagen von VBA vertraut:

- öffnen des Editors (z.B. ALT-F11)
- Tests mit sehr einfachen Codes ("Hello World")
- Einzelschritt-Modus

Youtube sollte einiges anbieten.

mfg

[schauan]

Hallo Steffen,

Poste bitte keine Datei wo ein Bild drin ist, das hilft nicht. Du könntest aber folgendes vorbereiten:

- zeichne ein Makro auf, wenn Du ein Bild einfügst. Siehe dazu in unserem Beispielbereich mein Beitrag zur Arbeit mit dem Makrorekorder
- schreibe in ein Blatt eine Liste der Bilder, die in diese Datei kommen sollen

ein aufgezeichnetes Makro zum Erstellen eines neuen Blattes und einfügen eines Bildes könnte so aussehen:

Code:

Sub Makro1()
'
' Makro1 Makro
'

'
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Pictures.Insert("C:\Temp\jahr1.png").Select
End Sub

Wenn Du für jedes Bild ein neues Excelblatt nimmst, dann macht man eine Schleife drumherum, die dann die Dateien entsprechend der Bilderliste einfügt.

Arbeitsblatt mit dem Namen 'Tabelle1'
	A
1	C:\Temp\jahr1.png
2	C:\Temp\jahr2.png
3

Verwendete Systemkomponenten: [Windows (32-bit) NT 10.00] MS Excel 2016

Diese Tabelle wurde mit Tab2Html (v2.6.2) erstellt. ©Gerd alias Bamberg

Das angepasste makro würde dann so aussehen, allerdings noch ohne Überschriften usw. und das Bild klemmt auch oben links ...

Code:

Option Explicit

Sub Makro1()
'Variablendeklaration - Integer
Dim iCnt%
'Startwert Schleifenzaehler setzen - hier fuer Zeile 1
iCnt = 1
'Schleife ueber alle Bildeintraege bis zur ersten leeren Zelle
Do While Sheets("Tabelle1").Cells(iCnt, 1).Value <> ""
    'Neues Blatt am Ende einfuegen
    Sheets.Add After:=ActiveSheet
    'Bild entsprechend Liste oben links einfuegen
    ActiveSheet.Pictures.Insert(Sheets("Tabelle1").Cells(iCnt, 1).Value).Select
    'Schleifenzaehler hochsetzen
    iCnt = iCnt + 1
'Ende Schleife ueber alle Bildeintraege bis zur ersten leeren Zelle
Loop
End Sub

Mappe siehe Anhang

[Steffen20]

Danke das ist schon besser. Wie kann ich es zentrieren und ein Überschrift hinzufügen?

---

Sorry wenn ich nochmal nerve. Ich würde es gerne so haben. Das pro Blatt 3 Bilder hinzugefügt werden. Die alle durchnummeriert sind z.b habe ich im verzeichnis bilder mit  0001.png  bis 0100.png.

und es soll jetzt auf erste blatt dann 0001.png - 0003.png reingeladen werden mittig und mit gleichen abstand. dann im blatt von 0004.png bis 0006.png usw...

Ist das auch möglich?

[Steffen20]

Code:

Sub Makro1TEEST()
'
' Makro1TEEST Makro
'

'
    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 399, 81, 54.75, _
        13.5).Select
    Range("K7").Select
    ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
    Selection.ShapeRange.ScaleWidth 12, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 3, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 24
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent6
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = -0.25
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 192, 0)
        .Transparency = 0
        .Solid
    End With
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
        "Hier Steht der Überschrift"
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 26). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 10).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 32
        .Name = "+mn-lt"
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(11, 16).Font
        .BaselineOffset = 0
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 32
        .Name = "+mn-lt"
    End With
    Range("F17").Select
    ActiveSheet.Pictures.Insert("C:\Temp\bild1.png").Select
    Selection.ShapeRange.IncrementLeft -72
    Selection.ShapeRange.IncrementTop -84
    Range("E5").Select
    ActiveSheet.Pictures.Insert("C:\Temp\bild2.png").Select
    Selection.ShapeRange.IncrementLeft 504.75
    Selection.ShapeRange.IncrementTop 97.5
    Selection.ShapeRange.IncrementLeft 125.25
    Selection.ShapeRange.IncrementTop 12.75
    Range("D20").Select
    ActiveSheet.Shapes.Range(Array("Picture 2")).Select
    Selection.ShapeRange.IncrementLeft -104.25
    Selection.ShapeRange.IncrementTop -5.25
    ActiveSheet.Shapes.Range(Array("Picture 5")).Select
    Selection.ShapeRange.IncrementLeft -233.25
    Selection.ShapeRange.IncrementTop -18.75
    ActiveSheet.Shapes.Range(Array("Picture 2")).Select
    Selection.ShapeRange.IncrementLeft 25.5
    Selection.ShapeRange.IncrementTop 36
    ActiveSheet.Shapes.Range(Array("Picture 5")).Select
    Selection.ShapeRange.IncrementLeft 30
    Selection.ShapeRange.IncrementTop 41.25
    ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
    Selection.ShapeRange.IncrementLeft 140.25
    Selection.ShapeRange.IncrementTop 7.5
    Columns("M:M").Select
    ActiveSheet.Pictures.Insert("C:\Temp\bild3.png").Select
    Selection.ShapeRange.IncrementLeft 468

Hallo, ich konnte jetzt zumindest 3 Bilder und eine Überschrft hinzufügen. Wie kann ich da jetzt eine schleife einbauen?

[schauan]

Hallöchen,

hier mal wieder etwas theorie. Eine Schleife für 3 Bilder je Blatt könnte man so aufbauen:

Code:

For iCnt = 1 To 100  'Neues Blatt am Ende einfuegen
    Sheets.Add After:=ActiveSheet
    'Bild entsprechend Liste oben links einfuegen
    Cells(2, 2).Select
    ActiveSheet.Pictures.Insert(Format(iCnt, "0000") & ".png").Select
    Cells(12, 2).Select
    ActiveSheet.Pictures.Insert(Format(iCnt + 1, "0000") & ".png").Select
    Cells(22, 2).Select
    ActiveSheet.Pictures.Insert(Format(iCnt + 2, "0000") & ".png").Select
    'Schleifenzaehler hochsetzen
    iCnt = iCnt + 2
'Ende Schleife ueber alle Bildeintraege bis zur ersten leeren Zelle
Next

Auf dem neuen Blatt werden nacheinander die 3 Bilder in die Zellen B2, B12 und B22 eingefügt. Dazu wird die entsprechende Zelle ausgewählt und der Bildname über den Format-Befehl gebildet. Vor dem Vormat müsste noch
"LW:\Pfad\" &
kommen. Am Ende der Schleife wird der Zähler noch um 2 hochgesetzt, damit es beim nächsten Durchlauf mit Bild 0004 weitergeht.

[Steffen20]

Danke für deine Hilfe. Aber ich bekomme eine fehlermeldung bei ActiveSheet.Pictures.Insert("D:\LOOP\" & (Format(iCnt, "0000") & ".png")).Select

Code:

Sub MakroEXCEL()
For iCnt = 1 To 100  'Neues Blatt am Ende einfuegen
    Sheets.Add After:=ActiveSheet
    'Bild entsprechend Liste oben links einfuegen
    Cells(2, 2).Select
    ActiveSheet.Pictures.Insert("D:\LOOP\" & (Format(iCnt, "0000") & ".png")).Select
    Cells(12, 2).Select
    ActiveSheet.Pictures.Insert("D:\LOOP\" & (Format(iCnt + 1, "0000") & ".png")).Select
    Cells(22, 2).Select
    ActiveSheet.Pictures.Insert("D:\LOOP\" & (Format(iCnt + 2, "0000") & ".png")).Select
    'Schleifenzaehler hochsetzen
    iCnt = iCnt + 2
'Ende Schleife ueber alle Bildeintraege bis zur ersten leeren Zelle
Next
End Sub

---

Hab das problem gefunden