Bilder einfügen in anderem Registerblatt

Question

Hallo Zusammen,

ich hatte gestern eine Anfrage, die auch wunderbar gelöst wurde
( https://supportnet.de/t/2485817 ).

Allerdings stellen sich mir nun noch ein paar weitere Hürden, und da ich den alten Threat bereits als erledigt markiert hatte, muss ich wohl einen neuen öffnen.

Um Folgendes geht es:
Ich habe eine Excel-Datei in der im Registerblatt A in der ersten Spalte Artikel-Nummern stehen, in Spalte D & E stehen Produktabmessungen. Nun gibt es ein Makro, dass anhand der Artikel-Nr aus einem hinterlegten Pfad ein Bild mit den Seitenlängen der Angaben in Spalte D & E einfügt. Soweit, so wunderbar, hier nochmal das bisherig Makro:

Sub Bilder_einfügen_Test_Drei()
Dim Pfad As String
Dim strDatnam As String
Dim lngZeile As Long
Dim dblBreit As Double
Dim dblHoch As Double

On Error Resume Next
'Pfad anpassen
Pfad = "C:\Users\dawollny\Desktop\Emotions\"
'Ab Zeile 1 werden alle Zeilen in Spalte A durchlaufen
For lngZeile = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Name des Bildes steht in Spalte A ohne Endung - Endung ggf. anpassen
strDatnam = Pfad & ActiveSheet.Cells(lngZeile, 1).Value & ".jpg"
'Breite und Höhe werden berechnet; 1 mm = 2,835 pt
dblBreit = ActiveSheet.Cells(lngZeile, 6).Value * 2.835 'Breite steht in Spalte E in mm
dblHoch = ActiveSheet.Cells(lngZeile, 5).Value * 2.835 'Höhe steht in Spalte D in mm
'Bild einfügen
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(lngZeile, 7).Left, Cells(lngZeile, 7).Top, dblBreit, dblHoch
Next lngZeile

End Sub





Nun habe ich in Spalte F noch eine Zahl, die angibt wie oft ich ein Bild dieses Artikels benötige. (z.B., steht dort eine "3", soll das Artikelbild dreimal eingefügt werden)

Außerdem habe ich festgestellt, dass es nicht sinnvoll ist, wenn die Bilder in Registerblatt A eingefügt werden, besser wäre ein Einfügen in Registerblatt B.

Um die Herausforderung auf die Spitze zu treiben: Derzeit liegen die eingefügten Bilder alle "übereinander". Gibt es eine Möglichkeit die Bilder nebeneinander einfügen zu lassen? (Ich habe im Registerblatt A eine feste Koordinate (H10), in der ich festlegen möchte, über wieviel Reihen ich alle Bilder angezeigt haben möchte.
Auch hier ein Beispiel: Angenommen es sind insgesamt 18 Bilder einzufügen, ich habe in H10 die Zahl 5 stehen, so sollten im Optimalfall die Bilder gleichmäßig über 5 Reihen verteilt eingefügt werden, in der 1.Reihe 4 Bilder, in der 2.Reihe 4 Bilder, in der 3.Reihe 4 Bilder, in der 4.Reihe 4 Bilder, in der 5.Reihe der Rest (2 Bilder),

Answer 1

Hallo,

probier mal das folgende Makro:

Sub Bilder_einfügen_neu()
Dim Pfad As String
Dim strDatnam As String
Dim lngZeile As Long
Dim lngGesamtzeilen As Long
Dim lngBilderanzahl As Long
Dim lngAnzahl As Long
Dim lngLetzte As Long
Dim i As Long
Dim j As Long
Dim dblBreit As Double
Dim dblHoch As Double
Dim dblLinks As Double
Dim dblOben As Double
Dim dblMax As Double
Dim strQuelle As String
Dim strZiel As String
Dim myRange As Range
Dim arrZeilen As Variant
Dim lngZaehler As Long
Dim lngZeilenzaehler As Long
Dim lngRest As Long

strQuelle = "Tabelle1" 'Tabellenname, in der die Daten stehen
strZiel = "Tabelle3" 'Tabellenname, in der die Bilder eingefügt werden

'Pfad in dem die Bilder gespeichert sind - anpassen!!
Pfad = "C:\Users\Test\Pictures\"

'Oberen und linken Rand festlegen
dblOben = 100
dblLinks = 10

'letzte Zeile in Quelle-Tabelle festlegen
lngLetzte = ThisWorkbook.Worksheets(strQuelle).Cells(Rows.Count, 1).End(xlUp).Row

'Anzahl der Gesamtzeilen einlesen, in die die Bilder eingefügt werden sollen
lngGesamtzeilen = ThisWorkbook.Worksheets(strQuelle).Range("H10")
ReDim arrZeilen(lngGesamtzeilen)

'Gesamtanzahl der Bilder ermitteln
Set myRange = ThisWorkbook.Worksheets(strQuelle).Range("F1:F" & lngLetzte)
lngBilderanzahl = Application.WorksheetFunction.Sum(myRange)

'Bilder auf die Zeilen verteilen (per Ganzzahl)
i = Int(lngBilderanzahl / lngGesamtzeilen)
For j = 0 To lngGesamtzeilen - 1
arrZeilen(j) = i
Next j

'nun ggf. den Rest verteilen
If lngBilderanzahl Mod lngGesamtzeilen > 0 Then
For j = 0 To lngBilderanzahl Mod lngGesamtzeilen - 1
arrZeilen(j) = arrZeilen(j) + 1
Next j
End If

On Error Resume Next

'Ab Zeile 1 werden alle Zeilen in Spalte A durchlaufen
For lngZeile = 1 To lngLetzte
'Name des Bildes steht in Spalte A ohne Endung - Endung ggf. anpassen
strDatnam = Pfad & ThisWorkbook.Worksheets(strQuelle).Cells(lngZeile, 1).Value & ".jpg"
'Breite und Höhe werden berechnet; 1 mm = 2,835 pt
dblBreit = ThisWorkbook.Worksheets(strQuelle).Cells(lngZeile, 5).Value * 2.835 'Breite steht in Spalte E in mm
dblHoch = ThisWorkbook.Worksheets(strQuelle).Cells(lngZeile, 4).Value * 2.835 'Höhe steht in Spalte D in mm
lngAnzahl = ThisWorkbook.Worksheets(strQuelle).Cells(lngZeile, 6).Value 'wie oft soll das Bild eingefügt werden, Spalte F
'Bild einfügen
For i = 1 To lngAnzahl
ThisWorkbook.Worksheets(strZiel).Shapes.AddPicture strDatnam, msoFalse, msoTrue, dblLinks, dblOben, dblBreit, dblHoch
dblLinks = dblLinks + 15 + dblBreit 'neue Position für das nächste Bild
If dblMax < dblHoch Then dblMax = dblHoch 'größte Bildhöhe in eine Variable schreiben
lngZaehler = lngZaehler + 1 'Zähler für eingefügte Bilder erhöhen
If lngZaehler = arrZeilen(lngZeilenzaehler) Then 'Prüfen, ob Anzahl der Bilder für die Zeile erreicht ist
lngZaehler = 0 'falls ja, dann Zähler zurücksetzen
lngZeilenzaehler = lngZeilenzaehler + 1 'Zähler für die Anzahl der eingefügten Zeilen erhöhen
dblLinks = 10 'Variable für Abstand vom Seitenrand für Bild zurücksetzen
dblOben = dblOben + 10 + dblMax 'Variable für Abstand vom oberen Rand um größte Bildhöhe plus 10 pt erhöhen
dblMax = 0 'dann die Variable wieder auf Null setzen
End If
Next i

Next lngZeile

End Sub

Den Pfad und die Namen der entsprechenden Tabellen musst du natürlich auf deine Bedürfnisse anpassen.

Gruß

M.O.

Answer 2

Hallo M.O.,


super, nach Tests kann die vollumfängliche Funktionalität bestätigen.
Super Job, vielen vielen Dank!

Gruß