automatische voettekst vanuit cel + tekststijl

[koster1984]

Hallo,

Ik heb al een tijdje hier op het forum gezocht naar een stukje code om automatisch, vanuit een cel, de voetteksten in te stellen. Wat ik aantrof werkte vaak wel, maar het enige waarvan de werking overal ontbreekt is het kunnen instellen van de tekststijl.

In bijgevoegd voorbeeldbestand staan de cellen A2, A3 en A4 voor resp. de left-, center- en rightfooter, met als centerfooter [pagina] / &[pagina's] en daaronder het lettertype, -grootte en of vetgedrukt is of niet (dat laatste hoeft niet perse uit de cellen gehaald te worden, die opgegeven waardes zijn vrij standaard).

Bekijk bijlage Voettekst.xlsm

Weet iemand misschien hoe dat moet?

Alvast bedankt.


Gr,
Daniel

 

[HSV]

Stoei hier eens wat mee.

Sub hsv()
With ActiveSheet.PageSetup
opmaak = Range("A3") & "," & Range("B5")
  .LeftHeader = "&"" & opmaak & ""&" & Range("A4") & Range("A2")
  .RightHeader = "&"" & opmaak & ""&" & Range("C4") & Range("C2")
 End With
End Sub

 

[koster1984]

Hoi Harry,

Alhoewel je header's i.p.v. footers hebt gemaakt (maar dat kan ik aanpassen), werkt het prima... dus dank daarvoor!
Ik zou alleen willen dat ie het standaard doet (of evt. als je de inhoud van de cellen wijzigt), i.p.v. dat je hem via macro's moet activeren. Kan dat ook?

Gr,
Daniel

 

[HSV]

Ik had headers genomen om niet steeds te moeten scrollen om te testen.
In moduleblad van toepassing.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:C5")) Is Nothing Then
  With ActiveSheet.PageSetup
opmaak = Range("A3") & "," & Range("B5")
   .LeftHeader = "&"" & opmaak & ""&" & Range("A4") & Range("A2")
   .RightHeader = "&"" & opmaak & ""&" & Range("C4") & Range("C2")
  End With
 End If
End Sub

 

[koster1984]

Ah zodoende..

Er is nog één dingetje wat raar doet;
Als ik kijk naar de opmaak van de voettekst, op het moment dat ik de code zijn werk heb laten doen, geeft ie als lettertype " & opmaak & ". Dat klop niet helemaal of wel?

 

[HSV]

Misschien dat het hier door komt.

De 'opmaak' is gebaseerd op alleen maar A3 en B5.
Maak voor elke opmaak een nieuwe regel.

opmaak1 = Range("A3") & "," & Range("A5")
opmaak2 = Range("B3") & "," & Range("B5")
opmaak3 = Range("C3") & "," & Range("C5")
    .Leftfooter = "&"" & opmaak1 & ""&" & Range("A4") & Range("A2")
    .centerfooter = "&"" & opmaak2 & ""&" & Range("B4") & Range("B2")
    .Rightfooter = "&"" & opmaak3 & ""&" & Range("C4") & Range("C2")

 

[koster1984]

Nee haalt niets uit.. dan zet ie " & opmaak1 & " t/m " & opmaak3 & ".

Tevens neemt ie het ook niet mee als ik aangeef het vetgedrukt te willen

 

[koster1984]

Maar goed maakt niet uit, zo kom ik er in principe ook enigszins mee uit de voeten.. Echter heb ik wel een nieuw probleem:
De cellen die de voettekst bepalen worden op hun beurt weer bepaalt door een cel in een ander tabblad (tab #, cel A1), Als ik nu die cel in tabblad # aanpas, wordt de code niet doorgevoerd. Ik had de code al geprobeerd aan te passen in de 2e regel (achter: "if not intersect"), maar dat lukt niet. Kan jij dat toevallig?

 

[HSV]

Op het moment ben ik zover.
Alleen het vet invullen wil niet erg goed vlotten.
De ene keer achteraan in de code werkt het, maar dan werkt er weer iets anders niet.

 

[koster1984]

Ziet er goed uit... dankje! Ik heb een beetje wat lopen trekken aan je code en ik krijg hem helemaal (incl. vet, lettertype en weet ik het wat). Ik heb in de cellen A-, B- en C3 het lettertype als volgt geschreven: &"Times New Roman" (met dubbele aanhalingstekens) waarna hij het wel doet.

De code ziet er nu als volgt uit:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:C5")) Is Nothing Then
  With ActiveSheet.PageSetup
opmaak1 = Range("A3") & Range("A5")
opmaak2 = Range("B3") & Range("B5")
opmaak3 = Range("C3") & Range("C5")

    .LeftFooter = opmaak1 & "&" & Range("A4") & Range("A2") & Range("A5")
    .CenterFooter = opmaak2 & "&" & Range("B4") & Range("B2") & Range("B5")
    .RightFooter = opmaak3 & "&" & Range("C4") & Range("C2")
  End With
 End If
End Sub

Hierbij het bestandje, met de code zoals hierboven, ook nog voor de volledigheid:
Bekijk bijlage Voettekst(1)(testje).xlsm

Alleen zat ik alweer met iets nieuws, ik had het al gepost.. maar dat was net voor jou reactie, dus quote ik mezelf even:

...De cellen die de voettekst bepalen worden op hun beurt weer bepaalt door een cel in een ander tabblad (tab #, cel A1), Als ik nu die cel in tabblad # aanpas, wordt de code niet doorgevoerd. Ik had de code al geprobeerd aan te passen in de 2e regel (achter: "if not intersect"), maar dat lukt niet. Kan jij dat toevallig?

 

[HSV]

Ik wil je niet teleurstellen Daniël, maar helaas wordt de tekst en lettergrootte niet meegenomen door verandering.

Ik kijk later terug voor je nieuwe vraagstelling.

 

[koster1984]

Bij mij wel.. Let wel dat ik er weer Footers van heb gemaakt ipv Headers (de Headers veranderen niet nee).

Prima, ik ben zelf inmiddels ook weer thuis..

 

[HSV]

Ach, natuurlijk, zit ik een beetje bovenin te kijken.
Mooi opgelost.

 

[HSV]

Bedoel je dit.

Knip de code en plak het in de bladmodule van toepassing.

 

[koster1984]

Welke code?

 

[koster1984]

Ik heb al een stukje code gevonden welke perfect werkt (alleen wat traag sinds ik zo'n 50 tabbladen heb)..

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("BT2")) Is Nothing Then

  With Sheets("$$").PageSetup
...etc.

Dus ik ben er helemal uit, ik zet hem op 'opgelost'. Bedankt voor je hulp!

Gr,
Daniel