Extra regel toevoegen in catalogus programma

[HWV]

Bekijk bijlage catalogus met foto.zip Bekijk bijlage Fotoboek voorbeeld resultaat.xlsx

Beste,

Met behulp van het forum ben ik tot een catalogusprogramma gekomen wat echt goed werkt.
Nu is het zo dat ik op elke nieuwe blad bovenaan een regel krijg waar ik dan de thema kan invullen die van toepassing voor dat blad.
De regel moet het volgende bevatten
- cellen samenvoegen a t/m E
- rijhoogte 50 pixels
- tekstgroot 22
- bold
- pagina einde plaatsen boven de ingevoegde regel.

In de bijlage heb ik het programma gedaan met de code`s hoe ver ik nu ben.
Ook heb ik een bijlage erbijgedaan blad 1 hoe het programma de opbouw nu doet
en blad 2 hoe ik het graag zou willen hebben.

Wie kan mij hier verder mee opweg helpen.

Ik hoor hte graag wie mij kan helpen.

groet HWV

'-------------------------------------------------------------
'Maken van het fotoboek
'--------------------------------------------------------------

Sub VerplaatsFotoboek()
'deze macro bouwt het fotoboek telkens helemaal opnieuw op.
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With


'maakt het blad2 (fotoboek) leeg
With Blad2.Cells
    .EntireRow.AutoFit
    .Clear
End With

'telt het aantal regels in de sheet met de namenlijst
cntRows = Sheets("lijst").Range("A2").CurrentRegion.Rows.Count
Blad2.Range("A1,B1,C1").ColumnWidth = 29.14

'stapt door blad1 (lijst) heen in stappen van 3 regels
For i = 1 To cntRows Step 3
    Blad1.Cells(i, 1).Resize(3, 3).Copy                                             'kopieert telkens een bereik van 3 rijen en 2 kolommen
    Blad2.Range("A65000").End(xlUp).Offset(2, 0).PasteSpecial , , , Transpose:=True 'zoekt de laats gevulde regel, gaat naar de eerste lege plakt de 3 rijen in de kolommen en de 2 kolommen in 2 rijen
    Blad2.Range("A65000").End(xlUp).Offset(-3, 0).EntireRow.Insert                  'stapt 1 regel boven fotonaam en voegt een regel in
    
    Blad2.Range("A65000").End(xlUp).Offset(-4, 0).RowHeight = 2.25
    Blad2.Range("A65000").End(xlUp).Offset(-3, 0).RowHeight = 157.5                   'stelt voor die ingevoegde regel de rijhoogte in
    Blad2.Range("A65000").End(xlUp).Offset(5, 0).EntireRow.Insert

Next

    Sheets("Fotoboek").Select
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp


opmaak
InsertPictureFotobook
save1

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

End Sub

'-------------------------------------------------------------
'Pagina indeling maken in 9 vakken met grijze strepen
'--------------------------------------------------------------

Sub opmaak()
    
    Sheets("Fotoboek").Select
    
   Blad2.Columns("B:B").Insert
    Blad2.Columns("D:D").Insert
    Blad2.Range("B1,D1").ColumnWidth = 0.25
    Blad2.Columns("A:E").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
    End With
    Range("A1").Select

    Range("B1:B" & Cells(Rows.Count, 1).End(xlUp).Offset(-3).Row).Select
      With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        End With
    
    Range("D1:D" & Cells(Rows.Count, 1).End(xlUp).Offset(-3).Row).Select
      With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        End With


cntRows = Blad2.UsedRange.Rows.Count + 1
i = 1
For rw = 8 To cntRows Step 5
    If i < 3 Then
        For col = 1 To 1
            With Cells(rw, col)
                On Error Resume Next
                With Selection.Interior
                    .Top = Cells(rw - 2, col).Resize(1, 5).Select
                    .ColorIndex = 15
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                End With
            End With
        Next
        i = i + 1
    Else
        i = 1
    End If
Next

End Sub

'-------------------------------------------------------------
Foto`s toevoegen aan het fotoboek
'--------------------------------------------------------------

Sub InsertPictureFotobook()

    Sheets("Fotoboek").Select
    
cntRows = Blad2.UsedRange.Rows.Count + 1
For rw = 3 To cntRows Step 5
    For col = 1 To 5
        With Cells(rw, col)
        On Error Resume Next
             With ActiveSheet.Pictures.Insert("P:\automatisering\mijn afbeeldingen\Website afbeeldingen\472 DS_Photo\" & Cells(rw, col) & ".jpg")
                    .Top = Cells(rw - 1, col).Top + 4
                    .Left = Cells(rw - 1, col).Left + 4
                    .Width = 150 ''(.Heigh / .Width) * Cells(rw, col + 4).Width
                    .Height = 150 ''Cells(rw, col).Width
                End With
        End With
    Next
Next

End Sub

'-------------------------------------------------------------
'Copy maken van het werkblad, en bestanden afsluiten
'--------------------------------------------------------------

Sub save1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Fotoboek").Copy
End With
     End With

Windows("GST1- Eenheden1.xls").Close SaveChanges:=False
Windows("catalogus met foto.xlsm").Close SaveChanges:=False                 
                          
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[Elsendoorn2134]

HWV,

Hoop tekst maar een beperkte vraag, voor het instellen van een kopregel heb de de volgende
code nodig

Sub Macro1()
    With Range("A1:E1")
        .RowHeight = 50
        .MergeCells = False
        .Size = 22
        .Font.Bold = True
    End With
End Sub

Maar ik vermoed dat dit niet de enigste vraag is die je wil stellen, alleen kan ik die niet uit de tekst opmaken.
Je heb een heel stuk code bijvoorbeeld opgenomen zonder er een vraag in te verwerken.

Veel Succes.

 

[HWV]

Misschien verkeerd geformuleerd

Beste,

Wat ik wil bereiken is het volgende:

Ik begin met een leeg blad met de VBA code (zie hiervoor) ga ik elke keer drie artikelnummers en omschrijvingen plaatsen vanaf het eerste tabblad, dan plaats ik de foto`s en geef ik de opmaak.
Dan is de bedoeling dat er dus op elk blad Dus regel 1, 17, 33, 49, 65 enz. kolom At/m E worden samengevoegd dan:

.RowHeight = 50
        .MergeCells = False
        .Size = 22
        .Font.Bold = True

Voor zover het blad gevuld is met het fotoboek.
Sorry maar ik weet niet hoe ik het anders moet uitleggen

Sub InvoegenKolom()
    Dim i As Long
    For i = 1 To 150 Step 16
        Rows(i).Insert xlShiftToRight
    Next
End Sub

Hier doe ik een regel toevoegen op de juiste plek, nu moet hij variabel dus de kolommen A t/m E samenvoegen eb de opmaak verzorgen.N
u loop ik vast. Want waar de 150 staat moet ook variabel zijn omdat de code moet doorgaan net zolang tot de laatst gevulde lijn van onder.


Groet HWV

 

[HWV]

weer een stap verder

Ik ben er achter gekomen om een regel toe te voegen boven aan elke bladzijde, en de cellen met elkaar te samen voegen.

Sub InvoegenKolom()

    Dim i As Long
    For i = 1 To 350 Step 17
        Rows(i).Insert xlShiftToRight
             Rows(i).Select
        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 4)).Merge
    Next
    
End Sub

Boven de cellen die zijn samengevoegd plaats ik een pagina einde met de volgende code

Sub regeleindetoevoegen()

    Dim i As Long
    For i = 17 To 350 Step 17
             Rows(i).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    Next
    
End Sub

Nu wil de cellen die ik heb samengevoegd een eigenschap meegeven:
.RowHeight = 50
.Size = 22
.Font.Bold = True
Ik weet niet hoe ik dit voor elkaar moet krijgen,

Natuurlijk zou dit in één code verwerkt moeten zijn maar voor mij werkt dit en anders weet ik niet hoe ik het voor elkaar moet krijgen.

Graag zou ik hulp hierin willen ontvangen.

Alvast bedankt

HWV

 

[HWV]

Is gelukt

Het kan waarschijnlijk veel beter en een mooiere code, maar voor mij werkt het nu in zijn geheel.
Ik heb met onderstaande code het volgende bereikt:

- voeg een regel toe om de 16 regels
- voeg een pagina einde toe om de 16 regels
- voeg de cellen A t/m E samen
- stelt een rij hoogte in

Al met al een code die een leuk foto boek neerzet

Sub InvoegenKolom()

    Dim i As Long
    For i = 17 To 350 Step 16
        Rows(i).Insert xlShiftToRight
             Rows(i).Select
        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 4)).Merge
          
    Next
    
    Dim ii As Long
    For ii = 17 To 350 Step 16
             Rows(ii).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    
    With Selection.Font
        .Name = "Verdana"
        .Size = 22
    End With
    
    With ActiveCell
    .RowHeight = 33
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
    End With
    Next
    
    Range("A1:E1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .MergeCells = True
    End With
      With Selection.Font
        .Name = "Verdana"
        .Size = 22
    End With
    
    Rows("1:1").Font.Bold = True
    Rows("1:1").RowHeight = 33
    
End Sub

Groet HWV:thumb: