formatage en vb feuile

[ElRagondindo]

Re bonjour a tous j'ai realiser un petit bouton qui me lance une macro qui me permet d'appliquer dans certaine plages une police et un saut de page tous les X cellules

Sub boutonformat_Cliquer()
Dim n1 As Long
Dim n2 As Long

n1 = 3
n2 = 16
Do While n1 < 2500

Range(Cells(n1, 1), Cells(n1, 6)).Font.FontStyle = "EanT30Rfz"

ActiveWindow.SelectedSheets.HPageBreaks.Add before:=Rows(n2)

n1 = n1 + 3
n2 = n2 + 15

Loop



End Sub

cependant je n'ai aucune police qui s'applique ???
La police etant installeé dans windows de type truetype ( police de code barre)

Qui aurait une idée car je n'ai pas de retour d'erreur...


Merci bien

 

[MichD]

Re : formatage en vb feuile

Bonjour,

Si tu veux modifier la police de ta plage, tu devrais utiliser ceci :

En supposant que cette police "EanT30Rfz" est installée :

Range(Cells(n1, 1), Cells(n1, 6)).Font.Name = "EanT30Rfz"

 

[ElRagondindo]

Re : formatage en vb feuile

*donc j'ai fait des modifs selon ce que tu disais.
Sub boutonformat_Cliquer()
Dim n1 As Long
Dim n2 As Long
Dim n3 As Long


n1 = 3
n2 = 16
n3 = 1

ActiveWindow.ActiveSheet.ResetAllPageBreaks
ActiveSheet.DisplayAutomaticPageBreaks = True

Do While n1 < 2500



With Range(Cells(n3, 1), Cells(n3, 6))
With .Font
.Name = "Comic Sans MS"
.Size = 18
.Bold = True
End With
End With



With Range(Cells(n1, 1), Cells(n1, 6))
With .Font
.Name = "EanT30Rfz"
.Size = 36
End With
End With


ActiveWindow.SelectedSheets.HPageBreaks.Add before:=Rows(n2)

n1 = n1 + 3
n2 = n2 + 15
n3 = n3 + 3


Loop

End Sub


Cependant l’exécution du code est trés long. Y a t'il moyen d'optimiser la vitese d'execution ca dure bien 15 minutes sur une pages de 2500 lignes.

 

[MichD]

Re : formatage en vb feuile

Bonjour,


Si j'ai bien traduit ta macro, celle-ci devrait être plus rapide!

Sub test()

Dim Rg As Range, Sh As Worksheet
Dim Arr(), A As Integer, Elt As Variant

Arr = Array("=MOD(row(A2),3)=0", "=MOD(row(A1),3)=0")

Set Sh = Worksheets("Feuil5") 'Nom feuille à adapter

Application.ScreenUpdating = False
ActiveWindow.ActiveSheet.ResetAllPageBreaks
ActiveSheet.DisplayAutomaticPageBreaks = True

For Each Elt In Arr
    With Sh
        Set Rg = Range("A1:F2500")
        .Range("H1") = ""
        .Range("H2").Formula = Elt
    End With
    
    With Rg
        .AdvancedFilter xlFilterInPlace, Sh.Range("H1:H2")
        If A = 0 Then
            With .Range("_FilterDataBase").Offset(1). _
                Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                With .Font
                    .Name = "EanT30Rfz"
                    .Size = 36
                End With
            End With
            A = A + 1
        ElseIf A = 1 Then
            With .Font
                .Name = "Comic Sans MS"
                .Size = 18
                .Bold = True
            End With
            A = A + 1
        End If
    End With
Next
For A = 16 To Rg.Rows.Count Step 15
    Sh.HPageBreaks.Add Before:=Sh.Rows(A)
Next
Sh.ShowAllData
Sh.Range("H2") = ""
Application.ScreenUpdating = False
End Sub

 

[ElRagondindo]

Re : formatage en vb feuile

Le temps d'execution est aussi lent ou rapide.

j'ai une erreur sh.ShowAllData ???

Je ne connais pas cette procédure

 

[MichD]

Re : formatage en vb feuile

Voici un fichier exemple. Sur mon ordi., cette procédure est
beaucoup plus rapide que celle que tu as publiée!

Le code du fichier exemple :

Sub test()
 
Dim Rg As Range, Sh As Worksheet, ModeCalcul As Long
Dim Arr(), A As Integer, Elt As Variant, Adr As String

'-------------Variables à définir----------------
Set Sh = Worksheets(ActiveSheet.Name) 'Nom feuille à adapter
'------------------------------------------------

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Reset_Mise_En_page Sh

Arr = Array("=MOD(row(A2),3)=0", "=MOD(row(A1),3)=0") 

For Each Elt In Arr
     With Sh
        .Range("A2600") = 1
        Set Rg = Range("A1:F2500")
        .Range("H1") = ""
        .Range("H2").Formula = Elt
    End With
     
    With Rg
        .AdvancedFilter xlFilterInPlace, Sh.Range("H1:H2")
        If A = 0 Then
            With .Range("_FilterDataBase").SpecialCells(xlCellTypeVisible)
                With .Font
                    .Name = "EanT30Rfz"
                    .Size = 36
                End With
            End With
            A = A + 1
        ElseIf A = 1 Then
            With .Font
                .Name = "Comic Sans MS"
                .Size = 18
                .Bold = True
            End With
            A = A + 1
        End If
    End With
    Sh.ShowAllData
    DoEvents
Next

For A = 16 To Rg.Rows.Count Step 15
    Sh.HPageBreaks.Add before:=Sh.Rows(A)
Next
With Sh
    .DisplayPageBreaks = True
    .Range("A2600") = ""
    Adr = .UsedRange.Address
    .Range("H2") = ""
    With .Shapes("Bouton 1")
        .Left = Sh.Range("C2").Left
        .Top = Sh.Range("C2").Top
        .Width = Sh.Range("C2:F2").Width
        .Height = Sh.Range("C2:C3").Height
    End With
End With
Application.Calculation = ModeCalcul
Application.ScreenUpdating = True
End Sub
'------------------------------------------------ 
Sub Reset_Mise_En_page(Sh As Worksheet)
Sh.ResetAllPageBreaks
Sh.UsedRange.Style = "Normal"
End Sub