Jeg kan ikke ændre fontstørrelse

Sub test()
Cells.Select
    Cells.EntireColumn.AutoFit
   
    With ActiveSheet.PageSetup
       
        .LeftHeader = "Skolekørsel xx skole"
        .CenterHeader = ugedag & " " & dagNr & " " & mdÅr
        .RightHeader = "SKOLE RUTE " & busNr
        .LeftFooter = "Udskrevet &D &T"
        .RightFooter = "&P af &N"
       
        .Orientation = xlLandscape
        .Zoom = 100
        Selection.Font.Bold = True
        Selection.Font.Size = Selection.Font.Size + 2
    End With
End Sub

Ha ha, du er også under vba. I mit første oplæg havde jeg skrevet, at denne kode er lavet af dig, supertekst, men da jeg tænkte du ikke var her, VBA, fjernede jeg det. Havde det været under excel, havde jeg skrevet det. :-)

Din kodning virker, jeg ville bare ændre et par småting. Vi fik lidt mere kørsel og jeg tænkte, vi kunne bruge dit program ca. 2 måneder, så får jeg digitale medier til at overtage (håber jeg).
Jeg kan ikke lige få det til at virke, når jeg sætter dit forslag ind.
Her er det oprindelige:

Rem Version 1 - 3/3-2011
Rem ====================

Const arkPrintNavn = "PrintArk"
Dim arkPrint As Worksheet

Dim arkBus As Worksheet
Public Sub TastUgeNr()
Dim ugeNr As Byte, indTast As String

    indTast = InputBox("Tast ugenr.", "Center-Service - Kørelister")
    If IsNumeric(indTast) = False Or indTast = "" Then
        MsgBox "Ugenr. er ikke numerisk/udfyldt- prøv igen"
        Exit Sub
    Else
        ugeNr = indTast
       
Rem definer Ark til print
        Set arkPrint = ActiveWorkbook.Sheets(arkPrintNavn)
       
        traverserBusArk ugeNr
    End If
End Sub
Private Sub traverserBusArk(ugeNr)
Dim busArk As Worksheet, ugefarve As Integer, ugeNrKol As Long, ugeStart As Long, ugeSlut As Long
Dim dagKol As Long

    Application.ScreenUpdating = False
   
    For Each busArk In ActiveWorkbook.Sheets
        If IsNumeric(busArk.Name) = True Then      'identificer ark med numerisk navn
            Set arkBus = busArk
            arkBus.Activate
           
            ugefarve = findUgeFarve(ugeNr, ugeNrKol)
           
            If ugefarve <> 0 Then
                ugeStart = findUgeStart(ugefarve, ugeNrKol)
                ugeSlut = findUgeSlut(ugefarve, ugeNrKol)
               
                For dagKol = ugeStart To ugeSlut
                    opbygUgeDagen dagKol, ugeNr, busArk.Name
                Next dagKol
               
            Else
                MsgBox "Ugenr.: " & CStr(ugeNr) & " er ikke fundet!"
                Exit Sub
            End If
        End If
    Next
   
    Application.ScreenUpdating = True
End Sub
Private Function findUgeFarve(ugeNr, ugeNrKol As Long)                'søg efter ugenr i række 1
Dim maxKol As Long, kol As Long, ugeNrPos As Long
    maxKol = findSidsteKol
   
    For kol = 1 To maxKol
        If Cells(1, kol) = ugeNr Then
            findUgeFarve = Range(Cells(1, kol), Cells(1, kol)).Font.ColorIndex
            ugeNrKol = kol
            Exit Function
        End If
    Next kol
   
    findUgeFarve = 0
    ugeNrKol = 0
End Function
Private Function findUgeStart(ugefarve, ugeNrKol As Long)          'søg <-- i række 2 indtil farve skifter
Dim kol As Long
    For kol = ugeNrKol To 1 Step -1
        If Range(Cells(2, kol), Cells(2, kol)).Font.ColorIndex <> ugefarve Then
            findUgeStart = kol + 1
            Exit Function
        End If
    Next kol
    findUgeStart = 0
End Function
Private Function findUgeSlut(ugefarve, ugeNrKol As Long)          'søg --> i række 2 indtil farve skifter
Dim kol As Long
    For kol = ugeNrKol To findSidsteKol
        If Range(Cells(2, kol), Cells(2, kol)).Font.ColorIndex <> ugefarve Then
            findUgeSlut = kol - 1
            Exit Function
        End If
    Next kol
    findUgeSlut = 0
End Function
Private Function findSidsteKol()
    findSidsteKol = ActiveCell.SpecialCells(xlLastCell).Column
End Function
Private Function findSidsteRæk()
    findSidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row
End Function
Private Sub opbygUgeDagen(kolNr, ugeNr, busNr As String)
Dim ugedag As String, udKort As String, dagNr As String, mdÅr As String
Dim dagStartRæk As Long, dagSlutRæk As Long, turkøbStartRæk As Long, turkøbSlutRæk As Long
Dim bTabel(), TKræk As Long, ix As Long

    ugedag = UCase(Format(Cells(3, kolNr), "DDDD"))
    udKort = Format(Cells(3, kolNr), "DDD")
   
    dagNr = Format(Cells(2, kolNr), "DD.")
    mdÅr = UCase(Format(Range("F2"), "MMM-YYYY"))
   
    dagStartRæk = findDagStart(udKort)
   
    If dagStartRæk > 0 Then
        dagSlutRæk = findDagSlut(udKort, dagStartRæk)
       
        turkøbStartRæk = findTurkøbStart(dagStartRæk, dagSlutRæk)
        If turkøbStartRæk > 0 Then
            turkøbSlutRæk = findTurkøbSlut(turkøbStartRæk, dagSlutRæk)
           
            ReDim bTabel(turkøbSlutRæk - turkøbStartRæk)
            ix = 0
           
Rem Gem kørselskoder i intern tabel
            For TKræk = turkøbStartRæk To turkøbSlutRæk
                bTabel(ix) = Cells(TKræk, kolNr)
                ix = ix + 1
            Next TKræk
           
Rem kopier Dagen til printArk
            kopierDagTilPrint dagStartRæk, dagSlutRæk, ugedag, dagNr, mdÅr, busNr, turkøbStartRæk, bTabel
        Else
            MsgBox "Turkøb på ugedag " & ugedag & " blev ikke fundet på bus " & busNr
        End If
    Else
        MsgBox "Start på ugedag " & ugedag & " blev ikke fundet på bus " & busNr
    End If
End Sub
Private Function findDagStart(ugedag As String)          'søg efter ugedag i kolonne Q + 1 op, når fundet
Dim ræk As Long
    For ræk = 4 To findSidsteRæk
        If InStr(LCase(Range("Q" & ræk)), ugedag) = 1 Then
            findDagStart = ræk - 1
            Exit Function
        End If
    Next ræk
    findDagStart = 0
End Function
Private Function findDagSlut(ugedag As String, startRæk)    'søg efter ugedag indtil ny ugedag eller sidste række - herefter op indtil samme ugedag fundet
Dim ræk As Long, sidsteRæk As Long
    For ræk = startRæk To findSidsteRæk
        If InStr(LCase(Range("Q" & ræk)), LCase(ugedag)) = 1 Then
            sidsteRæk = ræk
        Else
            If Range("Q" & ræk) <> "" Then
                findDagSlut = sidsteRæk
                Exit Function
            End If
        End If
    Next ræk
   
    findDagSlut = sidsteRæk
End Function
Private Function findTurkøbStart(dagStartRæk As Long, dagSlutRæk As Long)
Dim ræk As Long
    For ræk = dagStartRæk To dagSlutRæk
        If LCase(Range("E" & ræk)) = "turkøb" Then
            findTurkøbStart = ræk + 1
            Exit Function
        End If
    Next ræk
   
    findTurkøbStart = 0
End Function
Private Function findTurkøbSlut(turkøbStartRæk As Long, dagSlutRæk As Long)
Dim ræk As Long
    For ræk = turkøbStartRæk To dagSlutRæk
        If Range("E" & ræk) = "" Then
            findTurkøbSlut = ræk - 1
            Exit Function
        End If
    Next ræk
   
    findTurkøbSlut = 0
End Function
Private Sub kopierDagTilPrint(dagStartRæk As Long, dagSlutRæk As Long, ugedag As String, dagNr As String, mdÅr As String, busNr As String, turkøbStartRæk, bTabel())
Dim ræk As Long, ix As Long, antalSlet As Long, sidsteRække As Long
    arkPrint.Select
    arkPrint.Cells.Select
    Selection.Delete Shift:=xlUp
   
Rem Slet evt. rammer
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    arkBus.Select
    Range("D" & dagStartRæk & ":P" & dagSlutRæk).Select
    Selection.Copy
   
    arkPrint.Select
    arkPrint.Range("A1").Select
    ActiveSheet.Paste
    Columns("H:H").Select                          'slet bynavn
    Selection.Delete Shift:=xlToLeft
   
    Application.CutCopyMode = False
   
Rem Slet rækker i Turkøb, der ikke er "B"
    antalSlet = 0
   
    For ix = UBound(bTabel) To 0 Step -1
        If LCase(bTabel(ix)) <> "b" Then
            ræk = (turkøbStartRæk + ix) - dagStartRæk + 1
            arkPrint.Rows(ræk & ":" & ræk).Select
            Selection.Delete Shift:=xlUp
            antalSlet = antalSlet + 1
        End If
    Next ix

Rem Beregn Sidste række
    sidsteRække = dagSlutRæk - antalSlet - dagStartRæk + 1

Rem Juster cellebredder
    Cells.Select
    Cells.EntireColumn.AutoFit
   
    With ActiveSheet.PageSetup
        .LeftHeader = "Center-Service"
        .CenterHeader = ugedag & " " & dagNr & " " & mdÅr
        .RightHeader = "BUS " & busNr
       
        .LeftFooter = "Udskrevet &D &T"
        .RightFooter = "&P af &N"
       
        .Orientation = xlLandscape
        .Zoom = 92
    End With
   
    For ræk = 1 To sidsteRække
        If ræk Mod 2 = 0 Then
            Range("A" & ræk & ":L" & ræk).Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.149998474074526
                .PatternTintAndShade = 0
            End With
        End If
    Next ræk
   
    arkPrint.PageSetup.PrintArea = "A1:L" & CStr(sidsteRække)
   
    arkPrint.PrintOut
    arkBus.Select
End Sub

Det er:  .LeftHeader = "Center-Service"  som jeg lige ville forstørre...

Som altid: tak for din interesse!

Hej

Vender tilbage i morgen og selv tak :-)

Det blev så nu - alligevel.

    With ActiveSheet.PageSetup
        .LeftHeader = "&""-,Fed""&13Center-Service"  '<-----
    End With

Afprøvet ?

Lukketid?