Foto s op vooblad, herhalen als blad nog niet vol is

[HWV]

Beste,

Ik heb een script voor het maken van een fotoboek.
Nu wil ik daar een voorblad bij maken met de artikelen die in het fotoboek staan.
Op het voorblad komen dus de 176 kleine foto s te staan die ook in het fotoboek staan.
Enkel als er minder dan 176 foto`s zijn pakt hij nu "Geen_foto".

Is het mogelijk als ik b.v. maar 45 foto s heb dat hij dan weer bij de eerste foto begin totdat het eerste blad geheel gevuld is met kleine foto`s

Hieronder het script die het nu doet enkel zonder de herhaling.

- Zet eerst de artikelnummers in de cellen
- Dan plaatst hij de foto`s op de plek van het artikelnummer

'============================================
'Voorblad maken
'============================================
Sub VerplaatsVoorblad()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'maakt het blad2 (Voorblad) leeg
With Blad2.Cells
    .EntireRow.AutoFit
    .Clear
End With
    
'telt het aantal regels in de sheet met de namenlijst
cntRows = Sheets("lijst").Range("A1").CurrentRegion.Rows.Count
Blad2.Range("A1:K1").ColumnWidth = 7.43
Blad2.Range("A1:K17").RowHeight = 42.75

For i = 1 To cntRows Step 11
    Blad1.Cells(i, 1).Resize(11, 1).Copy                                             'kopieert telkens een bereik van 1 tot 11
    Blad2.Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial , , , Transpose:=True 'zoekt de laats gevulde regel, gaat naar de eerste lege plakt de gegevens
Next
    Sheets("Voorblad").Select
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp

PlaatsFoto
    
    Cells.Select
    Selection.ClearContents
    
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub


Sub PlaatsFoto()

  c00 = "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\"
   
  For j = 1 To 16
    For jj = 1 To 11
      With Sheets("Voorblad").Cells(j, jj)
        If Dir(c00 & .Value & ".jpg") <> "" Then
     .Parent.Shapes.AddPicture c00 & .Value & ".jpg", 0, 1, .Left + 4, .Offset(0).Top + 4, 35, 35
      Else
     .Parent.Shapes.AddPicture c00 & "Geen_foto" & ".jpg", 0, 1, .Left + 4, .Offset(0).Top + 4, 35, 35
      End If
      End With
    Next
  Next
End Sub

Ik hoop dat er iemand is die mij hier in kan ondersteunen.

HWV

 

[Timshel]

Ik probeer maar wat.
Zonder voorbeeld waarmee ik kan testen is de kans groot dat er nog bugs in zitten.

Sub VerplaatsVoorblad()
    Dim i As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
'maakt het blad2 (Voorblad) leeg
        With Blad2.Cells
            .EntireRow.AutoFit
            .Clear
        End With
'telt het aantal regels in de sheet met de namenlijst
        cntRows = Sheets("lijst").Range("A1").CurrentRegion.Rows.Count
        Blad2.Range("A1:K1").ColumnWidth = 7.43
        Blad2.Range("A1:K17").RowHeight = 42.75
        For i = 1 To cntRows Step 11
            Blad1.Cells(i, 1).Resize(11, 1).Copy
            Blad2.Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial , , , Transpose:=True
        Next
        Sheets("Voorblad").Activate
        Rows("1:1").Delete Shift:=xlUp
        Call PlaatsFoto(cntRows)
        Cells.ClearContents
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Private Sub PlaatsFoto(lRijen As Long)
    Dim j As Long, k As Long
    Dim c00 As String

    c00 = "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\"
   
    For j = 0 To 175
        k = j Mod lRijen
        With Sheets("Voorblad").Cells(1 + (j \ 11), (j Mod 11) + 1)
            .Parent.Shapes.AddPicture c00 & .Parent.Cells(1 + (k \ 11), 1 + (k Mod 11)).Value & ".jpg", 0, 1, .Left + 4, .Top + 4, 35, 35
        End With
    Next
End Sub

 

[HWV]

Helaas idd met bug, nu bestand toegevoegd

Bekijk bijlage catalogus met foto.xlsm

Beste Timshel,

Ik heb een bestand toegevoegd want het script geeft een foutmelding op :

Call PlaatsFoto[COLOR="#FF0000"](cntRows)[/COLOR]

Bedankt in ierder geval voor je hulp, en hoop dat de bug er ook uit te halen is.


Zelf ook nog bezig geweest en met een andere insteek met een toevoeging op de code hierboven:
Zo vult hij eerst aan tot het aantal regels dat we nodig hebben. Zodat het gehele voorblad gevuld word.
Nu nog iets van een rondom om alles door elkaar te krijgen

Sub ArtikelenAanvullen()
   
cntRows = Sheets("lijst").Range("A1").CurrentRegion.Rows.Count
If cntRows < "176" Then
aantal = "176" - cntRows
Sheets("lijst").Range("A1:A" & aantal).Copy
Sheets("lijst").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
End If
End Sub

HWV

 

[snb]

Private Sub M_snb()
    c00 = "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\"
    sn = Sheets("Lijst").Cells(1).CurrentRegion
    
    For j = 0 To 175
      With Sheets("Voorblad")
        .Shapes.AddPicture c00 & sn(j Mod UBound(sn) + 1, 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
      End With
    Next
End Sub

NB vermijd spaties in padnamen.

 

[HWV]

Draait perfect

Beste SNB,

Bedankt voor uw oplossing, het doet wat het moet doen.
Ik kan hier zeker wat mee.

Wel een aanvullende vraag is het mogelijk om in plaats van dat het netjes op volgorde plaats dat hij het in willerkeurige volgorde het voorblad vult.
ik weet niet of het mogelijk is, maar zou wel mooi zijn.

En anders ben ik al heel blij met deze oplossing

HWV

 

[snb]

Je vraagt nogal wt...

Hiermee zou je een eind moeten kunnen komen:

Sub M_snb()
  sn = Sheets("Lijst").Cells(1).CurrentRegion
    
  With Sheets("lijst").Cells(1, 100).Resize(UBound(sn))
    .Formula = "=rand()"
    st = Evaluate("index(rank(" & .Address & "," & .Address & "),)")
    .ClearContents
  End With
    
  For j = 0 To 175
    With Sheets("Voorblad")
        .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
    End With
  Next
End Sub

 

[HWV]

 .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35

Ik krijg de volgende melding op de code:
Typen komen niet met elkaar overeen.

Ik zou er wel naar willen kijken maar dit gaat toch wel even ver (heel ver) boven mijn pet.

HWV

 

[snb]

Test eens met:

Sub M_snb()
  sn = Sheets("Lijst").Cells(1).CurrentRegion
    
  With Sheets("lijst").Cells(1, 100).Resize(UBound(sn))
    .Formula = "=rand()"
    st = Evaluate("index(rank(" & .Address & "," & .Address & "),)")
    .ClearContents
  End With

  With Sheets("Voorblad")
     For j = 0 To 175
       msgbox st(j Mod UBound(sn) + 1, 1)
       msgbox sn(st(j Mod UBound(sn) + 1, 1),1)
       msgbox "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg"
       .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
     Next
  End With
End Sub

 

[HWV]

SNB,

Zie de volgende melding

    MsgBox st(j Mod UBound(sn) + 1, 1)

Ik krijg de volgende melding op de code:
Typen komen niet met elkaar overeen.

HWV

 

[snb]

Doorloop de code stap voor stap met F8

Kijk naar de gegevens in kolom CV. (=kolom 100)
Stel het numberformat van kolom CV in op 'general'.

Sub M_snb()
  sn = Sheets("Lijst").Cells(1).CurrentRegion
    
  With Sheets("lijst").Cells(1, 100).Resize(UBound(sn))
    .Formula = "=rand()"
    st = Evaluate("index(rank(" & .Address & "," & .Address & "),)")
'    .ClearContents
  End With

' With Sheets("Voorblad")
'   For j = 0 To 175
'       msgbox st(j Mod UBound(sn) + 1, 1)
'       msgbox sn(st(j Mod UBound(sn) + 1, 1),1)
'       msgbox "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg"
'       .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
'     Next
' End With
End Sub

 

[HWV]

Gebeurd veel

SNB,

Ik heb de code doorlopen en zie nu inderdaad dat er in kolom CV de getallen 0 en 1 komen te staan.
Ik krijg de meldingen van de msgbox ook door, maar hoe kan ik de code nu laten lopen zonder dat hij de msgbox laat zien

HWV

 

[Haije]

door een enkele ' voor de regel te plaatsen?

 

[HWV]

Gelukt

Hoe moeilijk moet het zijn

Ik had dit eerst gedaan maar met fout, maar ik moet beginnen in sheet lijst dan gaat het goed.
Ik wil iedereen bedanken voor zijn hulp en zeker SNB voor zijn hulp, en zeker de rondom werkt perfect,

HWV

 

[snb]

In de kolom CV moet getallen van minstens 5 cijfers achter de komma komen.
Kijk eens naar de opmaak van die kolom.

Uiteindelijk moet je alleen de code uit post #6 laten lopen. De andere zijn testmacro's.

Voor de goede orde: het gaat hier om random (-willekeurig/toeval) en niet om rondom (zo geavanceerd is Excel nog niet )

 

[HWV]

Duidelijk !

Erg bedankt voor uw hulp! :thumb:

HWV

 

[HWV]

SNB,

Toch nog 1 vraag.
Als de foto niet bestaat geef hij nu een foutmelding, hij zou dan eigenlijk de foto "geen_foto.jpg" moeten pakken.

Sub MM_snb()
      
    Sheets("Lijst").Select
      sn = Sheets("Lijst").Cells(1).CurrentRegion
    
  With Sheets("lijst").Cells(1, 100).Resize(UBound(sn))
    .Formula = "=rand()"
    st = Evaluate("index(rank(" & .Address & "," & .Address & "),)")
    .Columns("CV:CV").ClearContents
  End With

 With Sheets("Voorblad")
   For j = 0 To 175
      '' MsgBox st(j Mod UBound(sn) + 1, 1)
      '' MsgBox sn(st(j Mod UBound(sn) + 1, 1), 1)
      '' MsgBox "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg"
       .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
     Next
 End With
End Sub

In de code die ik gebruik voor de catalogus zelf heeft u SNB dit ook kunnen inbouwen

Sub PlaatsFoto()

  c00 = "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\"
   
  For j = 1 To 16
    For jj = 1 To 11
      With Sheets("Voorblad").Cells(j, jj)
        If Dir(c00 & .Value & ".jpg") <> "" Then
     .Parent.Shapes.AddPicture c00 & .Value & ".jpg", 0, 1, .Left + 4, .Offset(0).Top + 4, 35, 35
      Else
    [COLOR="#FF0000"] .Parent.Shapes.AddPicture c00 & "Geen_foto" & ".jpg", 0, 1, .Left + 4, .Offset(0).Top + 4, 35, 35[/COLOR]
      End If
      End With
    Next
  Next
End Sub

Ik heb naar een oplossing gekeken maar zoals ik al eerder heb aangegeven gaat dat even boven mijn pet

Alvast dank voor uw hulp hiermee

HWV

 

[snb]

1. het is me niet duidelijk welke code je nu gebruikt.
2. verwijder sheets("lijst").select, dat is volledig overbodig
3. verwijder .offset(0), dat is volledig overbodig
4. waarom staan er überhaupt in werkblad 'lijst' foto-namen die niet bestaaan ? Zorg dat daar alles picobello is, en je hebt geen code meer nodig die de fouten in dat werkblad op moet vangen ('aanpakken bij de bron' heet dat).

 

[HWV]

Beste SNB,

Sorry voor de onduidelijkheid in mijn vraagstelling.

1) Deze code gebruik ik nu voor het voorblad.

Sub MM_snb()
      
    Sheets("Lijst").Select
      sn = Sheets("Lijst").Cells(1).CurrentRegion
    
  With Sheets("lijst").Cells(1, 100).Resize(UBound(sn))
    .Formula = "=rand()"
    st = Evaluate("index(rank(" & .Address & "," & .Address & "),)")
    .Columns("CV:CV").ClearContents
  End With

 With Sheets("Voorblad")
   For j = 0 To 175
      '' MsgBox st(j Mod UBound(sn) + 1, 1)
      '' MsgBox sn(st(j Mod UBound(sn) + 1, 1), 1)
      '' MsgBox "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg"
       .Shapes.AddPicture "P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & sn(st(j Mod UBound(sn) + 1, 1), 1) & ".jpg", 0, 1, .Columns(j Mod 11 + 1).Left + 4, .Rows(j \ 11 + 1).Top + 4, 35, 35
     Next
 End With
End Sub

2) Heb ik aangepast en verwijderd in de code voor de catalogus

3) Zal die bekijken, dit is een eerder script waar in u heeft meegeholpen.

4) Ik zal u kort uitleggen waar ik het voor gebruik, terwijl u wel gelijk heb maar het nu niet anders is.
Ik gebruik het voorblad met de gegevens uit de lijst, die lijst is samengesteld uit een assortiment van een klant.
Aangezien we hier over 12.000 artikelen praten en wij nog niet alle foto`s in orde hebben is het wel eens noodzakelijk om een afbeelding Geen_foto.jpg te gebruiken.

Ik ben het met u eens dat de lijst in orde moet zijn en dat alle afbeeldingen moeten bestaan, wat helaas nog niet het geval is.

Dit is dus de reden waarom ik dit zou willen hebben in de code die hierboven staat.

HWV

 

[Ginger]

@HWV, je zou tav punt 4 óók kunnen zeggen dat je een veld aan die tabel moet toevoegen. Bijvoorbeeld de veldnaam Foto_Aanwezig als boolean veld (dus TRUE als de foto er is of FALSE als deze er niet is) kan je een eind op weg helpen. Dit helpt jou als mens om via een filter visueel te zien wat je nog mist aan foto's en in je code kan je heel simpel bepalen of je de echte foto moet ophalen of die vaste waarde "geen foto".

 

[HWV]

@Ginger

Dit brengt zeker een uitkomst om in kaart te krijgen welke foto's er nog gemaakt moeten worden.

Enkel boolean erin bouwen gaat boven mijn pet in de code van SNB. Om zo de afebeelding Geen_foro.jpg te krijgen

HWV