Excel VBA Text einfügen für zig bilder

Question

Halli Hallo,
da es gestern bzw die letzten Tage hier so super mit den Hilfe von euch geklappt hat wofür
ich echt dankbar bin , dachte ich mir wir gehen weiter zu punkt 2 ^^.
Ich habe jetzt von M.O. einen text für VBA Programmiert bekommen den ich leicht geändetr
habe um mir die maße einzustellen.
Was jetzt noch genial wäre , wäre wenn ich neben jedem bild dazu noch fest gesetzte Texte
Habe die er mir neben jedes Bild Packt das ich einfüge.
So hier einmal der Programmierte text und darüber quasi das wie ich es mir rechts neben
dem Bild vorstelle. Kann auch eine excel datei zu schicken oder ein scrrenshot damit man
weis wie ich es meine. Weiß nur nicht wie ich das hier mache mit dem einfügen oder senden
habe es bis jetzt per email versendet.
Also hier der text   

Das ist der Text mit den EIgenschaften wie ich es gerne neben jedem Bild hätte.
Die leere zeilen, sollen halt leer bleiben damit ich dort die jeweiligen werte selber eintragen
kann.


- Lego Star Wars , Fett und unterstrichen Schriftgröße 14
- Name: Fett mit Unterstrich 12
-( Leere Zeile) 12
- Farben: Fett mit Unterstrich12
-( Leere Zeile)12
-( Leere Zeile )12
-Preis ca.: fett mit unterstrich12
-( Leere Zeile)12
Set Nr.: fett mit unterstrich
-( Leere Zeile)



Den geschriebenen Text von M.O. Habe ich so verändert :

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 ausschalten
.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")
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")
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 > 11 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
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile,
lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
End With

End If

DateiName = Dir
Loop

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub

Answer 1

Okay werde ich gleich versuchen. und das die leeren zeilen bzw zellen neben den bildern in kusiv und ohne untertrich und mittig sind was mache
ich da?
und mal eine noch blödere frage warscheinlich. geht es teoretisch, das man einen code schreibt der zu diesem hinzugefügt wird, der einem die
infos die man haben will bzw die bei mir noch fehlen passend zum bild selbständig von einer internetseite hinzufügt ?

Answer 2

Gibt es ein kommando bzw einen code wo ich schreiben kann das alle Zellen die keine Information enthalten lustig und in der Mitte sind den ich einfach
dazufügen kann ?

Answer 3

Hallo David,

die leeren Zeilen werden jetzt kursiv und zentriert formatiert:

[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
Dim rngText As Range

With Application
  .ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
  .EnableEvents = False 'Ereignisse
  .Calculation = xlCalculationManual 'automatische Berechnung 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"
   .HorizontalAlignment = xlCenter       'zentrieren
   With .Font
     .Name = "Calibri"         'Schriftart
     .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.:"
'und formatieren
Set rngText = Union(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 3, lngSpalte + 1), .Cells(lngZeile + 6, lngSpalte + 1), .Cells(lngZeile + 8, lngSpalte + 1))
With rngText.Font
  .Size = 12 'Schriftgröße
  .Bold = True 'Fett
  .Underline = xlUnderlineStyleSingle 'unterstrichen
End With
'Nun leere Zeilen für Text formatieren
Set rngText = Union(.Cells(lngZeile + 2, lngSpalte + 1), .Cells(lngZeile + 4, lngSpalte + 1), .Cells(lngZeile + 5, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1))
With rngText
 .HorizontalAlignment = xlCenter       'zentrieren
 With .Font
  .Size = 12 'Schriftgröße
  .Italic = True  'kursiv
 End With
End With

End With

End If

DateiName = Dir
Loop

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub[/code]
[quote]..geht es teoretisch, das man einen code schreibt der zu diesem hinzugefügt wird, der einem die
infos die man haben will bzw die bei mir noch fehlen passend zum bild selbständig von einer internetseite hinzufügt ? [/quote]
Da habe ich leider keine Ahnung

Gruß

M.O.

P.S.
Was meinst du hier mit "lustig"???
[quote]Gibt es ein kommando bzw einen code wo ich schreiben kann das alle Zellen die keine Information enthalten lustig und in der Mitte sind den ich einfach dazufügen kann ?[/quote]

Answer 4

Okay Danke :-)
Oh das Lustig sollte da garnicht mein keine ahnung warum ich das geschrieben habe^^
einfach nicht beachten ;-)

Answer 5

Hey M.O. eine Sache habe ich noch gefunden. Und zwar macht er mir mit dem COde aktuell nur die leere zelle unter Name und unter Farben: in kusiv und mittig zentriert.
Die anderen beiden unter Prei ca und Set Nr sind aktuell beide noch so eingestellt das sie nicht mittig zentriert sind und nicht kusiv. wenn du mir das noch machen könntest
dann ist der code für meinen zweck wirklich perfekt :-)
LG

Answer 6

Oh und ich habe eben gerade gesehen wenn ich weiter runter scrolle ist doch weider da Problem aufgetreten das er mir bilder abschneidet und teile von texten die noch nach
oben sollten auf eine andere dina4 seite abgeschnitten sind :-( habe ich vorher gatnicht gesehen weil ich immer nur die ersten paar Seiten nach gesehen hatte.
wie war noch mal deine email adresse dann sende ich dir die datei gespeichert mit dem aktuellen makro und den von mir eingefügten bildern wenn das okay ist

Answer 7

Hallo Julian,

ich habe dir die E-Mail-Adresse noch einmal per Pager zukommen lassen. Ich werden aber erst morgen Zeit haben, mir das mal anzuschauen.

Gruß

M.O.

Answer 8

Hallo Julian,

die Zeile unter Set-Nr. sollte eigentlich mittig und kursiv formatiert sein. Die unter dem Preis hatte ich vergessen.
Hier ist die geänderte Zeile für den Code:
[code]'Nun leere Zeilen für Text formatieren
Set rngText = Union(.Cells(lngZeile + 2, lngSpalte + 1), .Cells(lngZeile + 4, lngSpalte + 1), .Cells(lngZeile + 5, lngSpalte + 1), .Cells(lngZeile + 7, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1))
[/code]
Wenn ich mir deine Tabelle auf meinem Rechner ansehe, dann passen die Bilder perfekt auf die Seiten, auch die letzten Bilder. Wie ich schon geschrieben habe, können durch verschiedene Drucker die Seitenansichten variieren. Du kannst ja mal etwas mit den Seitenrändern oben und unten probieren. Wenn du dann die perfekte Einstellung gefunden hast, dann kannst du per Makroaufzeichnung die Seitenränder setzen und die Daten aus dem aufgezeichneten Makro in den bestehenden Code einfügen.

Ich werde mir die Tabelle auch noch einmal auf einem anderen Rechner mit anderem Drucker ansehen (das geht aber erst morgen).

Gruß

M.O.

Answer 9

Guten Morgen,

also wollte gerade deine Ergänzung einfügen in den aktuellen Code, aber finde die stelle irgendwie nicht wo es rein kommt.
Die überschrift bzw die Bezeichnung mit dem Hochkomma ist glaube ich eine Andere oder ?

Answer 10

Hallo Julian,

nein, den Text gibt es schon.
Hier das gesamte geänderte Makro:

[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
Dim rngText As Range

With Application
  .ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
  .EnableEvents = False 'Ereignisse
  .Calculation = xlCalculationManual 'automatische Berechnung 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"
   .HorizontalAlignment = xlCenter       'zentrieren
   With .Font
     .Name = "Calibri"         'Schriftart
     .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.:"
'und formatieren
Set rngText = Union(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 3, lngSpalte + 1), .Cells(lngZeile + 6, lngSpalte + 1), .Cells(lngZeile + 8, lngSpalte + 1))
With rngText.Font
  .Size = 12 'Schriftgröße
  .Bold = True 'Fett
  .Underline = xlUnderlineStyleSingle 'unterstrichen
End With
'Nun leere Zeilen für Text formatieren
Set rngText = Union(.Cells(lngZeile + 2, lngSpalte + 1), .Cells(lngZeile + 4, lngSpalte + 1), .Cells(lngZeile + 5, lngSpalte + 1), .Cells(lngZeile + 7, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1))
With rngText
 .HorizontalAlignment = xlCenter       'zentrieren
 With .Font
  .Size = 12 'Schriftgröße
  .Italic = True  'kursiv
 End With
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.