1.6k Aufrufe
Gefragt in Datenbanken von syler902 Mitglied (159 Punkte)
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

39 Antworten

0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
So habe das alles kopiert und eingefügt und auch wenn ich nicht auf drucken gehe sonder nur nach unten scrolle geht das mit abschneiden los bei zeile 141 da habe ich dann kein Platz mehr für die Set NR und
weiter unten kommen immer mal wieder fehler also bzw sieht man dort das es über die DinA4 Seite hinnaus geht.
und dieses mal habe ich es mir nur in der exceltabelle angeguckt und nicht in der Druckansicht also daran kann es nicht liegen
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Also ich habe eben noch mal geguckt. bei mir fängt es genau an quasi falsch zu laufen in der Zeile 48 / 49 da fängt er an das Bild einzufügen und setzt das Bild in die 49 sodass quasi zum rand oben an der Dina
A4 Seite schon mal eine Zeile frei gelassen wird. ( Ich habe bei mir dasd Seitenlayout einer DinA4 seite eingestellt und sehe immer die gestrichelten Linien die mir die DinA4 Seite anzeigen, danach richte ich mich
immer hoffe es gibt deswegen nicht irgendwelche unterschiede im Verstädniss^^
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

hier noch einmal ein überarbeiteter Code:
[code]Sub Bilder_einlesen_neu()

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
Dim lngSeite As Long

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
'Zähler für Seiten
lngSeite = 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
     lngSeite = lngSeite + 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
  'Prüfen ob 4 Bildereihen eingefügt wurden
  If lngSeite = 5 Then
    'falls ja, dann Zähler auf 1 zurücksetzen
     lngSeite = 1
    'und Seitenumbruch vor neuer Einfügezeile einfügen
    .Rows(lngZeile).PageBreak = xlPageBreakManual
  End If
  '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]
Jetzt wird vor jeder 5. Bilderreihe (=neue Seite) ein manueller Seitenumbruch eingefügt.
Schau mal, ob die Darstellung jetzt besser ist.

Gruß

M.O.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Keine Ahnung was gerade los ist, aber habe eine mail bekommen das ich hier eine antwort bekommen habe um kurz nach halb 2 heute. Wenn ich den text gehe bis hierhin sehe ich aber nichts neues an
nachrichten ^^ also keine ahnung ob er irgendwie noch braucht um sich zu aktualisieren aber kann ein klein augenblick dauern bis eine antwort von mir kommt auf das letzte was du geschrieben hast
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
haha okay kaum abgeschickt kann ich es natürlich lesen^^. Probiere es gleich aus
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Eine letzte Sache habe ich da noch. Kannst du mir jetzt noch einstellen das er unter Preis in der Leer spalte wo ich die Zahlen eingebe , das er mir da automatisch immer ein Euro Zeichen hinter meinen Preis setzt
?
Dann ist der Code für meine Zwecke echt Perfekt :-)
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Julian,

du hast aber auch Wünsche ;-):

[code]Sub Bilder_einlesen_neu()

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
Dim lngSeite As Long

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
'Zähler für Seiten
lngSeite = 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
     lngSeite = lngSeite + 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
  'Prüfen ob 4 Bildereihen eingefügt wurden
  If lngSeite = 5 Then
    'falls ja, dann Zähler auf 1 zurücksetzen
     lngSeite = 1
    'und Seitenumbruch vor neuer Einfügezeile einfügen
    .Rows(lngZeile).PageBreak = xlPageBreakManual
  End If
  '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
 'Zeile für Preis mit Euro formatieren
 .Cells(lngZeile + 7, lngSpalte + 1).NumberFormat = "#,##0.00 $"

End With

End If

DateiName = Dir
Loop

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

End Sub[/code]
Gruß

M.O.
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
So also ich habe eine email bekommen das hier einen neue atnwort geschrieben wurde. Hatte eigentlich schon geantwortet aber mache es dann noch mal.
Also was noch echt cool wäre wenn du mir noch einfügen kannst das der Preis nzw die zelle unter dem Preis mit einem Eurozeichen versehen wird. das wäre super bzw für meine Zwecke wäre der Code dann
echt perfekt :-) LG Julian
0 Punkte
Beantwortet von syler902 Mitglied (159 Punkte)
Hahaha okay jetzt habe ich die Nachricht geschickt und jetzt sehe ich die Antwort von vorhin xD also nicht beachten^^.
Haha ja ich weis ich komme mir auch schon ein wenig unvberschämt vor aber das macht es mir so viuel einfacher als alles selber zu machen und zu versuchen das alles alleine zu schaffen. Bist mir eine riesige
Hilfe ;-)
...