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:
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
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.......
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
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.......