van excellijst naar fotoboek

[HWV]

Beste,

Ik loop met het volgende rond.
Een fotoboek maken van één rij foto`s heb ik voor elkaar gekregen met onderstaande code.
Hij kijkt in kolom 2 of hij een overeenkomst heeft met de desbetreffende map waar mijn excel bestand in staat.
Zo ja dan plaats hij een foto in kolom 3 werkt perfect.

Graag zou ik het anders willen doen namelijk:
In de werkmap "lijst" staat een aantal nummers en omschrijving die ik in de map "fotoboek" zou willen hebben maar dan met drie foto`s naast elkaar met daaronder het artikelnummer en de regel daaronder dan de omschrijving.
Ik zou op het ogenblik niet weten hoe ik de code opzij kan laten kijken om de foto te plaatsen i.p.v. in kolom twee.
Tevens is de lijst elke keer verschillend van lengte, en opvolgend van nummer.
Deze dient dan ook zo te komen in het fotoboek, van links naar rechts opvolgend en dan weer verder op de volgende regel.
In de bijlage vind je een voorbeeld van hoe ik het in gedachten had.

Ik hoop dat we er samen uitkomen

Bekijk bijlage lijst naar fotoboek.xlsx

Option Explicit

Sub InsertPicture()
Dim i As Integer

i = 2
Do Until Cells(i, 2).Value = ""

On Error Resume Next
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Cells(i, 2).Value)
    .Top = Cells(i, 2).Top
    .Left = Cells(i, 3).Left
    .Width = (.Width / .Height) * Cells(i, 4).Height
    .Height = Cells(i, 2).Height
End With
i = i + 1
Loop
End Sub

Groet HWV

 

[HWV]

Beste,

Ik ben aan de slag gegaan met een VBA script maar loop toch vast.
Wat doet hij nu

Hij plaats het artikelnummer in kolom a,b,c
Hij plaast daaronder in kolom a,b, en c de omschrijving.
Maakt de cel boven het artikelnummer de juiste hoogt voor de foto.

Tot zover, maar...

Hij plaats elk artikelnummer in kolom a,b, en c ipv opvolgend

1151103 1151103 1151103
OPP flowwrap folie 430mm 30 micron OPP flowwrap folie 430mm 30 micron OPP flowwrap folie 430mm 30 micron

terwijl dit het resultaat zo moeten zijn

1151103 1151104 1151105
OPP flowwrap folie 430mm 30 micron OPP flowwrap folie 320mm 30 micron OPP flowwrap folie 340mm 30 micron

In de bijlage het voorbeeld bestand incl de code in de module

wie kan mij verder op weg helpen

Groet HWV

Sub VerplaatsFotoboek()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
   
   Sheets("lijst").Select
   
   Dim c As Range
   Dim c1 As Range
   For Each c In [A1:A10000]
   For Each c1 In [B1:B10000]
   


On Error Resume Next
'lege regel invoegen waar later de foto komt

Application.GoTo ['Fotoboek'!A65536].End(xlUp).Offset(-1, 0)
    ActiveCell.EntireRow.Insert shift:=xlShiftDown
ActiveCell.EntireRow.RowHeight = 168.75
'artikelnummer plaatsen
        If c > "" Then
            c.Copy
            ['Fotoboek'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            ['Fotoboek'!A65536].End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
            ['Fotoboek'!A65536].End(xlUp).Offset(0, 2).PasteSpecial xlPasteValues
        End If
        
'omschrijving plaatsen
            If c1 > "" Then
            c1.Copy
            ['Fotoboek'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            ['Fotoboek'!A65536].End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
            ['Fotoboek'!A65536].End(xlUp).Offset(0, 2).PasteSpecial xlPasteValues
            
        End If
    Next
Next

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

Bekijk bijlage lijst naar fotoboek.xlsm

 

[roeljongman]

ik wilde eerst corrigeren in de code maar heb uiteindelijk maar een nieuwe gemaakt die een stuk sneller is.

deze code vervangt wel steeds de hele inhoud als je de macro opnieuw draait, er kan ook vrij eenvoudig een versie van gemaakt worden die alleen toevoegt. na de laatste gevulde regel.

Sub VerplaatsFotoboek()

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

cntRows = Sheets("lijst").Range("A1").CurrentRegion.Rows.Count

With Blad2.Cells
    .EntireRow.AutoFit
    .Clear
End With
Blad2.Range("A1:C1").ColumnWidth = 32
For i = 1 To cntRows Step 3
    Blad1.Cells(i, 1).Resize(3, 2).Copy
    Blad2.Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial , , , Transpose:=True
    Blad2.Range("A65000").End(xlUp).Offset(-1, 0).EntireRow.Insert
    Blad2.Range("A65000").End(xlUp).Offset(-2, 0).RowHeight = 168.75
Next

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

 

[HWV]

Vervolgcode

Bedankt voor je reactie, en je werkende code.
Je heb inderdaad gelijk wat betreft de code die ik had gemaakt.
Ik doe het hobby matig werken met VBA, heb er geen opleiding ingevolgd (is dan ook wel te zien )

Maar goed, kan jij mij ook helpen om dan ook de foto`s te plaatsen wat ik nu met deze code doe:

Option Explicit

Sub InsertPicture()
Dim i As Integer

i = 2
Do Until Cells(i, 2).Value = ""

On Error Resume Next
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Cells(i, 2).Value)
    .Top = Cells(i, 2).Top
    .Left = Cells(i, 3).Left
    .Width = (.Width / .Height) * Cells(i, 4).Height
    .Height = Cells(i, 2).Height
End With
i = i + 1
Loop
End Sub

Deze code kijkt in kolom 2 naar artikelnummers en plaats deze dan in de zelfde rij één kolom verder.
Dit moet nu natuurlijk anders worden ivm dat het artikelnummer nu in kolom a,b en c staat.
Ik heb helaas niet de kennis om dit aan te passen, is dit wel mogelijk en zou jij mij verder willen helpen

Alvast bedankt

Groet HWV

 

[HSV]

Vermijd copy.
Kan 'paste' ook uit de code, net als cutcopymode = false.

Sub VerplaatsFotoboek()
Application.ScreenUpdating = False
 With Sheets("Fotoboek")
  .UsedRange.ClearContents
  .Cells.RowHeight = 15#
 cntRows = Sheets("lijst").Range("A1").CurrentRegion.Rows.Count
  For i = 1 To cntRows Step 3
   .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(2, 3) = Application.Transpose(Sheets("lijst").Cells(i, 1).Resize(3, 2).Value)
   .Cells(Rows.Count, 1).End(xlUp).Offset(-1, 0).EntireRow.Insert
   .Cells(Rows.Count, 1).End(xlUp).Offset(-2, 0).RowHeight = 168.75
     Next
   .Columns.AutoFit
 End With
End Sub

 

[roeljongman]

aangepaste code voor de insert picture.. het was vooral even pielen met de rijen en kolommen, vandaar dat ik dan graag rw en col gebruik ipv i en j, dat is gewoon persoonlijke voorkeur, dan snap ik zelf beter wat er gebeurd en het maakt niks uit qua uitvoer van de macro.

Sub InsertPicture()
cntRows = Blad2.UsedRange.Rows.Count + 1
For rw = 3 To cntRows Step 3
    For col = 1 To 3
        With Cells(rw, col)
        On Error GoTo einde
            With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Cells(rw, col).Value)
                 .Top = Cells(rw - 1, col).Top
                 .Left = Cells(rw - 1, col).Left
                 .Width = (.Width / .Height) * Cells(rw, col + 1).Height
                 .Height = Cells(rw - 1, col).Height
            End With
        End With
    Next
Next
einde:
End Sub

zie bijlage om veilig proef te draaien.. ik heb ook nog een aparte macro toegevoegd die die toevoegt aan bestaand fotoboek.. ipv opnieuw opbouwd dan heb je een redelijk compleet setje volgens mij..

 

[roeljongman]

@hsv dankje die application.transpose kende ik nog niet, afgelopen 2 maanden veel energie gestopt in mijn vba skills te verbeteren, zo weet in nu .activate, .select .copy / .paste meestal te vermijden alleen voor pastespecial kende ik nog geen alternatieve code.. dus nu daar maar eens op richten..

@hwv, zo zie ook ik ben maar een goedwillende amateur.. ik leer ook nog regelmatig nieuwe dingen bij.. .

 

[HSV]

Graag gedaan Roel,

Misschien is onderstaande ook een aandraging.

On Error Resume Next
            With ActiveSheet.Pictures.Insert("D:\Mijn afbeeldingen\HWV\" & Cells(rw, col) & ".jpg")

 

[roeljongman]

Graag gedaan Roel,

Misschien is onderstaande ook een aandraging.

On Error Resume Next
            With ActiveSheet.Pictures.Insert("D:\Mijn afbeeldingen\HWV\" & Cells(rw, col) & ".jpg")

Ja dat klopt.. ik heb hem zelf ook zo getest met ".jpg" erachter, maar omdat HWV aangaf dat hij nu al met de insertpicture() code werkte ben ik er maar van uitgegaan dat het bij hem werkt zonder die toevoeging en als de melding komt dat het niet lukt was dit mijn eerste aanpassing

De resume next heb ik juist vervangen door goto einde omdat hij anders vrij lang door leek te lopen terwijl er geen bestanden meer waren. maar bij nader inzien is resume next waarschijnlijk beter anders stopt hij zodra 1 foto ontbreekt en met resume next slaat hij gewoon die ene foto over maar plaatst de andere wel..

(ik gok dat in het echte fotobestand echte bestandsnamen staan en in het voorbeeld de extenties zijn weggelaten...)

 

[HWV]

toch nog een vraag

Beste roeljongman en HSV,

Bedankt voor de input werkt als een trein.
Ik had hier dus nooit zelf uitgekomen.

Ik ga nu een beetje stoeien met de uitstraling.

In iedergal tot zover heel erg bedankt

Groet HWV

Sub InsertPicture()
cntRows = Blad2.UsedRange.Rows.Count + 1
For rw = 3 To cntRows Step 3
    For col = 1 To 3
        With Cells(rw, col)
        On Error Resume Next
             With ActiveSheet.Pictures.Insert("D:\Trescon\ZNP\Foto`s\472 DS_Photo\" & Cells(rw, col) & ".jpg")
                    .Top = Cells(rw - 1, col).Top
                    .Left = Cells(rw - 1, col).Left
                    .Width = (.Width / .Height) * Cells(rw, col + 1).Height
                    .Height = Cells(rw - 1, col).Height
                End With
        End With
    Next
Next

End Sub