Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

sim

XLDnaute Occasionnel
Bonjour a toutes et a tous!!!

Bon voici le code que j'ai reussi a faire sous 2007, sur PC perso, mais cela ne fonctionne pas en 2003

J'ai essayer de detailler au maximum le code ( je ne peux pas mettre de fichier avec la meme structure ca me prendrai une semaine...)

J'explique aussi dans le code ce qui ne fonctionne pas, si quelqu'un pouvait m'aider a me depatouiller ca serait vraiement super!!!

Voici donc le code:

VB:
Private Sub Bouton_marches_Click()
Marches_usf.Show
End Sub
Private Sub Update_Array(array_title As String, value)
 ActiveSheet.PivotTables(array_title).PivotFields("Market"). _
            CurrentPage = value
End Sub
Private Sub Add_Lines_Area(n1, n2, n3)
        'La zone à modifier commence à la ligne n1 et se termine à la ligne n2
        'On doit rajouter des lignes vides dans cette zone
        'Ces lignes vides sont à rajouter au dessus de la ligne de niveau n2
        'Au final, la zone nouvelle aura une hauteur de n3 lignes. La première des n3 lignes est la ligne n1.
        'Le nouveau n2 verifie n'2 = n1 + n3
        
        Range(n2 & ":" & n2).Select
        For i = 1 To n1 + n3 - n2
        Selection.Insert Shift:=xlDown
        Next
End Sub
Private Sub Delete_Lines_Up(begin_pos, nb_lines)
        'begin_pos est le n° de ligne au dessus de laquelle on supprime des lignes
        'nb_lines est le nombre de lignes à supprimer
        Range(begin_pos - nb_lines & ":" & begin_pos - 1).Select
        Selection.Delete Shift:=xlUp
End Sub
Private Function Title_Position(title) As Double
Range("a1").Select
Title_Position = Cells.Find(What:=title, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Row
End Function
Private Sub Worksheet_Change(ByVal Target As Range)

'Définition des variables pour la mise en page
Dim p_start, p_end, h1, h2, high_zone, high_pt, nb_line As Double
Dim ht1, ht23, ht4, ht5, ht6 As Double          'taille maximale de chacune des zones accueillant un tableau
Dim t1, t2, t3, t4, t5, t6 As String

'Titres des paragraphes qui repèrent les 6 tableaux et hauteur maxi de chaque zone
' 1 ligne pour le titre de paragraphe, 1 ligne vide, 1 ligne de champ filtre,
' puis 1 ligne vide, les lignes du tableau, et des lignes vides jusqu'à la ligne juste avant le titre suivant

t1 = "Price Method and Incoterms applied"
ht1 = 27

t2 = "Affiliate selling to the Market's Distributor"
t3 = "Product Category sold to the Market"
ht23 = 26

t4 = "Business Flows"
ht4 = 46

t5 = "Factories and Brands"
ht5 = 56

t6 = "Royalties and Entrepreneur"

ActiveSheet.Rows.EntireRow.Hidden = False
Application.EnableEvents = False
    
'Suppression de fonds de couleur sur certains titres (en 2007)
'
'Ici est mon soucy le code .TintAndShade = 0 ne fonctionne pas je le met donc en commentaire. 

'
' Range("a2:Z500").Select
' With Selection.Interior
'        .Pattern = xlNone
'        .TintAndShade = 0
'        .PatternTintAndShade = 0
'    End With
 Range("A1").Select

 
    Application.ScreenUpdating = False
    If Target.Address = "$F$1" Then
        On Error Resume Next
        'TABLEAU "Price"
        'Rajout de lignes vides pour que la zone ait la hauteur ht1
        'Mise à jour du tableau
        'Calcul de la hauteur du tableau après sa mise à jour
        'Suppression de lignes vides, pour qu'il y ait plus que deux lignes vides après le tableau
               
        Call Add_Lines_Area(Title_Position(t1), Title_Position(t2), ht1)
        Call Update_Array("price", Target.value)
        high_pt = ActiveSheet.PivotTables("price").TableRange2.Rows.Count
        Call Delete_Lines_Up(Title_Position(t2), ht1 - high_pt - 4)

        'TABLEAU "affiliate" et "product" : mise à jour et recuperation de sa hauteur dans la variable hap2
        Call Add_Lines_Area(Title_Position(t2), Title_Position(t4), ht23)
          
        Call Update_Array("affiliate", Target.value)
        Call Update_Array("product", Target.value)
        h1 = ActiveSheet.PivotTables("affiliate").TableRange2.Rows.Count
        h2 = ActiveSheet.PivotTables("product").TableRange2.Rows.Count
        If h1 < h2 Then
        high_pt = h2
        Else: high_pt = h1
        End If
        
        Call Delete_Lines_Up(Title_Position(t4), ht23 - high_pt - 4)
        
        'TABLEAU "flows"
        Call Add_Lines_Area(Title_Position(t4), Title_Position(t5), ht4)
        Call Update_Array("flows", Target.value)
        high_pt = ActiveSheet.PivotTables("flows").TableRange2.Rows.Count
        Call Delete_Lines_Up(Title_Position(t5), ht4 - high_pt - 4)
        
        'TABLEAU "brand"
        Call Add_Lines_Area(Title_Position(t5), Title_Position(t6), ht5)
        Call Update_Array("brand", Target.value)
        high_pt = ActiveSheet.PivotTables("brand").TableRange2.Rows.Count
        Call Delete_Lines_Up(Title_Position(t6), ht5 - high_pt - 4)
        
        'TABLEAU "royalty" : mise à jour
        Call Update_Array("royalty", Target.value)
               
        On Error GoTo 0
    End If

'MISE EN PAGE
'---------------------------------------------------------------------------

'Suppression des sauts de page de la zone d'impression
 ActiveSheet.PageSetup.PrintArea = "$A$1:$Z$1000"
On Error Resume Next
    For j = ActiveSheet.HPageBreaks.Count To 1 Step -1
        ActiveSheet.HPageBreaks(j).Delete
    Next j
    On Error GoTo 0

'Reperage de la position du titre 5
 
 h1 = Title_Position(t5)
  
 'insertion d'un saut de page au niveau du titre 5
 Range("a" & h1).Select
 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  
 h2 = Title_Position(t6)

 If h2 > 90 Then
 Range("a" & h2).Select
 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
 End If

 'Masquage des lignes affichant les filtres des tableaux croises dynamiques (gain de 10 lignes en impression)
 
 h1 = Title_Position(t1)
 Rows(h1 + 2 & ":" & h1 + 4).Select
 Selection.EntireRow.Hidden = True
      
 h1 = Title_Position(t2)
 Rows(h1 + 2 & ":" & h1 + 3).Select
 Selection.EntireRow.Hidden = True
           
 h1 = Title_Position(t4)
 Rows(h1 + 2 & ":" & h1 + 4).Select
 Selection.EntireRow.Hidden = True
                
 h1 = Title_Position(t5)
 Rows(h1 + 2 & ":" & h1 + 4).Select
 Selection.EntireRow.Hidden = True
                     
 h1 = Title_Position(t6)
 Rows(h1 + 2 & ":" & h1 + 4).Select
 Selection.EntireRow.Hidden = True
 
  
 'Masquage des boutons dans les tableaux (uniquement en 2007)
 'ActiveSheet.PivotTables("price").ShowDrillIndicators = False
 'ActiveSheet.PivotTables("affiliate").ShowDrillIndicators = False
 'ActiveSheet.PivotTables("product").ShowDrillIndicators = False
 'ActiveSheet.PivotTables("flows").ShowDrillIndicators = False
 'ActiveSheet.PivotTables("brand").ShowDrillIndicators = False
 'ActiveSheet.PivotTables("royalty").ShowDrillIndicators = False
 
 'Amelioration du tableau "flows" : lignes intermediaires en pointiles pour les irules, et passage en arial narrow au lieu de arial
 h1 = Title_Position(t4)
 h2 = ActiveSheet.PivotTables("flows").TableRange2.Rows.Count
 Range("D" & h1 + 6 & ":G" & h1 + h2 + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
        .Weight = xlThin
    End With

'ICI le debugueur s'arrete sur .LineStyle = xlContinuous alors qu'il ne s'arrette pas sur 
'Selection.Borders(xlEdgeBottom)
'ni sur Selection.Borders(xlEdgeTop)
' ni sur Selection.Borders(xlEdgeLeft)
' qui sont pourtant situee avant


    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlDot
        .ColorIndex = 1
 '       .TintAndShade = 0
        .Weight = xlThin
    End With
    
     With Selection.Font
        .Name = "Arial Narrow"
        .Size = 10
    End With

'Amelioration du tableau "Factories and brands" : bordure sur le cote droit
 h1 = Title_Position(t5)
 h2 = ActiveSheet.PivotTables("brand").TableRange2.Rows.Count
 Range("G" & h1 + 5 & ":G" & h1 + h2 + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 1
  '      .TintAndShade = 0
        .Weight = xlThin
    End With

'Amelioration du tableau "Royalty" : bordure sur le cote droit
 h1 = Title_Position(t6)
 h2 = ActiveSheet.PivotTables("royalty").TableRange2.Rows.Count
 Range("G" & h1 + 5 & ":G" & h1 + h2 + 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 1
  '      .TintAndShade = 0
        .Weight = xlThin
    End With

'amelioration des entetes des tableaux : remplissage du fond
    
Color1 = -0.149998474074526
Color2 = -0.249977111117893
ColorCurrent = Color1

    'tableau "Price"
    h1 = Title_Position(t1) + 5
    Range("B" & h1 & ":F" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
'        .ThemeColor = xlThemeColorDark1
   '     .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    'tableau "affiliate"
    h1 = Title_Position(t2) + 5
   Range("B" & h1 & ":D" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
   '     .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    
    'tableau "product"
    h1 = Title_Position(t3) + 5
    Range("F" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
   '     .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    
    
   'tableau "flows"
    h1 = Title_Position(t4) + 5
    Range("B" & h1 & ":D" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
   '     .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    'tableau "brand"
    h1 = Title_Position(t5) + 5
    Range("B" & h1 & ":G" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
   '     .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    'tableau "royalty"
    h1 = Title_Position(t6) + 5
    Range("B" & h1 & ":G" & h1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
  '      .TintAndShade = ColorCurrent
        .PatternTintAndShade = 0
    End With
    
    
'reperage de la ligne apres le dernier tableau
 h1 = Title_Position(t6) + ActiveSheet.PivotTables("royalty").TableRange2.Rows.Count + 2
 
 'Zone d'impression resseree
 ActiveSheet.PageSetup.PrintArea = "$A$1:$G$" & h1
        
 Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .Zoom = 70
        
    End With
Application.PrintCommunication = True
        
        
'Columns("A:A").ColumnWidth = 15.43
 
 'Recalage en haut
 Range("a1").Select

Application.EnableEvents = True


End Sub


Voila, je suis vraiement dsl de ne pas pouvoir mettre de PJ, mais ca serait trop complique pour ne pas mettre d'info confidentielles


Merci en tout cas pour ceux qui auront jeter un coup d'oeil1111:eek:

Je reste connecte tte la journee pour d'eventuelles question!!!

Cordialement.

Sim

Edit: il a l'air de pas trop aimer le .ThemeColor = xlThemeColorDark1
non plus.......:(
 

sim

XLDnaute Occasionnel
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Bonjour!!!!

Deja merci pour la reponse!! :)

Alors le bug interviens

Code:
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous --------->>>>>ICI
        .ColorIndex = 1
 '       .TintAndShade = 0
       .Weight = xlThin
    End With


Ce que je comprend pas parce que il ne beug pas sur la meme ligne repetee trois fois juste au dessus....

Merci pour ton aide..

Sim
 

sim

XLDnaute Occasionnel
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Bon, voici une piece jointe simplifie

J'espere que ca permettra d'avancer,

j'ai supprimer le dernier TCD "royalty" pour des raison evidente de confidentialite

il faut donc ignorer la partie qui met en forme et met a jour ce dernier TCD, puisqu'il n'existe pas dans cette version....

J'espere que ca aidera....je rpesente le projet demain matin a 9h et ya rien qui marche oula oula oula oula


Mercid 'avance pour votre coup de main

Sim


Merci d'avance
 

Pièces jointes

  • Code_mise_en_pages.zip
    206.4 KB · Affichages: 43

Softmama

XLDnaute Accro
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Bonjour,

Peut-être, peux-tu déjà remplacer tout cela :

VB:
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
       .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
       .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
       .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 1
 '       .TintAndShade = 0
       .Weight = xlThin
    End With

Par juste cela :
VB:
    With Selection.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 1
       .Weight = xlThin
    End With

J'ignore si cela suffira à te débloquer cependant...
 

sim

XLDnaute Occasionnel
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Bon alors......lol

Ce que j'ai fait......

j'ai fait le changement propose du coup plus de beug sur cette partie la

mais j'ai aussi mis en commentaire cest ligne la a chaque fois qu'elle apparaissaient

Code:
'        .PatternColorIndex = xlAutomatic
'        .ThemeColor = xlThemeColorDark1
'        .TintAndShade = ColorCurrent
'       .PatternTintAndShade = 0

et du coup le debugueur s'arrete en fin de code sur

Code:
 Application.PrintCommunication = False

Voila.....
 

sim

XLDnaute Occasionnel
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Softmama ( lol j'aime bien ce pseudo!!)


Ba la je comprend pas ton dernier post parce que dans mon exemple le code est dans le module de la feuille 6.....

Est tu sur que les TCD ce mette a jours....pour verrifier aller voir le tcd Business Flow et regarder a la fin des Irules si c'est bien le bon marche....

Donc je comprend plus rien dans ce cas lol
 

JNP

XLDnaute Barbatruc
Re : Macro fonctionne en 2007, mais pas en 2003...besoin d'aide

Bonjour le fil :),
et du coup le debugueur s'arrete en fin de code sur
Code:
 Application.PrintCommunication = False
Voila.....
D'après l'aide, cette fonctionalité a été rajoutée... sur 2010 :p...
Comme elle ne sert (toujours d'après l'aide) qu'à accélérer le code en désactivant puis en réactivant l'imprimante, tu peux la mettre en commentaire, ainsi que celle qui le rétabli à True :rolleyes:...
Bon courage :cool:
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof