So habe es ausprobiert und komme bis zum wählen des Ordners, wenn ich diesen dann öffne kommt ein Laufzeit fehler der mir angezeigt
wird Laufzeitfehler 424 und er gibt mir an das ich beenden kann oder Debuggen. wenn ich auf Debuggen gehe wird nur noch ein einziges
Bild eingefügt.
Hier der Code den ich jetzt aus deinen beiden zusammen gebaut habe.
Sub Bilder_einlesen()
Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim rngSpalte As Range
With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
End With
'erste Zeile und Spalte zum Einfügen festlegen
lngZeile = 1
lngSpalte = 1
'Tabelle einrichten
'Spalten für Bilder Breite von 17,75 festlegen
With ActiveSheet
Set rngSpalte = .Range("A:A,C:C,E:E,G:G,I:I,K:K,M:M,O:O")
rngSpalte.ColumnWidth = 17.75
'Spalten für Erläuterungen Breite von 20 festlegen
Set rngSpalte = .Range("B:B,D:D,F:F,H:H,J:J,L:L,N:N,P:P")
rngSpalte.ColumnWidth = 20
'Seitenränder (jeweils 1,5 cm) einrichten
With .PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362) 'linker Seitenrand
.RightMargin = Application.InchesToPoints(0.590551181102362) 'rechter Seitenrand
.TopMargin = Application.InchesToPoints(0.590551181102362) 'oberer Seitenrand
.BottomMargin = Application.InchesToPoints(0.590551181102362) 'unterer Seitenrand
End With
End With
'Pfad auswählen und in Variable für Pfad schreiben
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then
strPfad = .SelectedItems(1) & "\"
Else
MsgBox "Kein Pfad gewählt! Abbruch!", 16, "Abbruch!" 'Abbrechen wenn kein Pfad ausgewählt wurde
Exit Sub
End If
End With
'nur Dateien mit Endung jpg und png öffnen
DateiName = Dir(strPfad)
Do While DateiName <> ""
If LCase(Right(DateiName, 3)) = "jpg" Or LCase(Right(DateiName, 3)) = "png" Then
lngZaehler = lngZaehler + 1 'Zähler für Bilder
'Zeile und Spalte für das einzufügende Bild festlegen
If lngZaehler > 1 Then
If lngZaehler Mod 6 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
Else
If lngZaehler > 1 Then 'ansonsten Einfügespalte neu festlegen
lngSpalte = lngSpalte + 2
If lngSpalte > 15 Then lngSpalte = 1
End If
End If
End If
'Bilder einfügen
'Bild in Zellen einfügen, 4,3 cm breit - 1 cm = = 28,35 pt ergibt 121,91 pt - und 6,64 cm hoch = 188,24
With ActiveSheet
'Bilder einfügen
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
'Text einfügen und formatieren
With Cells(lngZeile, lngSpalte + 1).Value = "Lego Star-Wars"
With .Font
.Size = 14 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With
End With
'Text einfügen, soweit vorhanden
.Cells(lngZeile + 1, lngSpalte + 1).Value = "Name:"
.Cells(lngZeile + 3, lngSpalte + 1).Value = "Farben:"
.Cells(lngZeile + 6, lngSpalte + 1).Value = "Preis ca.:"
.Cells(lngZeile + 8, lngSpalte + 1).Value = "Set Nr.:"
'weitere Zeilen formatieren
With .Range(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1)).Font
.Size = 12 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With
End With
End If
DateiName = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub