Hallo Julian,
ich habe noch einen Fehler gefunden. Hier der verbesserte Code:
[code]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 8 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
lngSpalte = 1
Else
If lngZaehler > 1 Then lngSpalte = lngSpalte + 2
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
.Name = "Calibri"
.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[/code]
Gruß
M.O.
