XL 2013 Créer un tableau par VBA selon des conditions

[onyirimba]

Bonjour,

J'ai 2 demandes : j'ai créé un codage qui met à jour un tableau de l'onglet "SYNTHESE VBA" en fonction de la colonne A B et C de l'onglet STC B2M

1. Je souhaiterai que cette mise à jour se réalise en fonction de la couleur bleue de l'onglet et non en fonction de la dénomination STC B2M de l'onglet. J'ai essayé avec le codage ci-après mais cela ne fonctionne pas.
2. Ensuite je souhaiterai que le tableau de l'onglet "SYNTHESE VBA" ait la mise en page ci-après donc j'ai crée un onglet Modele mais je n'ai pas trouvé le codage adéquat

Est-ce que vous pouvez m'aider ?

Mise en page souhaitée du tableau de l'onglet "SYNTHESE VBA" (que je n'arrive pas à coder)

J'ai joint un fichier illustratif

Merci pour votre aide

Sub test()
Dim Sh As Worksheet, C As Range
For Each Sh In Sheets
If Sh.Tab.ColorIndex = 33 Then

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
Dim nbLignes As Long


', dest As Range
Dim Deb As Long
Set ws = ThisWorkbook.Worksheets("SYNTHESE VBA")
'With ws
'.UsedRange.Offset(21, 0).Clear
'End With

'With Sheets("STC B2M")
For Each cel In .Range("A7:A" & .Range("A" & rows.Count).End(xlUp).Row)

If cel.Offset(, 0) Like "*STC B2M*" Then
dt = ws.Cells(rows.Count, 2).End(xlUp).Row + 1

ws.Range("B" & dt) = cel.Offset(, 0)
ws.Range("C" & dt) = cel.Offset(, 1)
ws.Range("D" & dt) = cel.Offset(, 2)
ws.Range("E" & dt).Formula = ws.Range("X" & dt).Formula
ws.Range("F" & dt).Formula = ws.Range("Y" & dt).Formula
ws.Range("G" & dt).Formula = ws.Range("Z" & dt).Formula
ws.Range("H" & dt).Formula = ws.Range("AA" & dt).Formula
ws.Range("I" & dt).Formula = ws.Range("AB" & dt).Formula
ws.Range("J" & dt).Formula = ws.Range("AC" & dt).Formula
ws.Range("K" & dt).Formula = ws.Range("AD" & dt).Formula
ws.Range("L" & dt).Formula = ws.Range("AE" & dt).Formula
ws.Range("M" & dt).Formula = ws.Range("AF" & dt).Formula
ws.Range("N" & dt).Formula = ws.Range("AG" & dt).Formula

End If

Next cel
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
Next Sh
End Sub

Onglet Modele qui sert à coder la mise en page du tableau de l'onglet "SYNTHESE VBA"

 

[onyirimba]

Bonjour,

J'ai trouvé la solution qui est le codage ci-après :

Sub test()


'''xxxxxxxxxxxxxxxxx EFFACEMENT DES DONNEES EXIXTANTES xxxxxxxxxxxxxxxxxxxx'''''
ThisWorkbook.Activate
Sheets("SYNTHESE").Select
Range("B7:N100000").Select
Selection.Clear

'''xxxxxxxxxxxxxxxxx EFFACEMENT DES DONNEES EXIXTANTES xxxxxxxxxxxxxxxxxxxx'''''




Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
Dim nbLignes As Long





', dest As Range
Dim Deb As Long
Set ws = ThisWorkbook.Worksheets("SYNTHESE")
Dim Sh As Worksheet, C As Range


For Each Sh In Sheets
If Sh.Tab.ColorIndex = 33 Then

'''''''''''''''''''''''''' RISK '''''''''''''


For Each cel In Sh.Range("A7:A" & Sh.Range("A" & Rows.Count).End(xlUp).Row)

dt = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1

ws.Range("B" & dt) = cel.Offset(, 0)
ws.Range("C" & dt) = cel.Offset(, 1)
ws.Range("D" & dt) = cel.Offset(, 2)
ws.Range("E" & dt).Formula = ws.Range("X" & dt).Formula
ws.Range("F" & dt).Formula = ws.Range("Y" & dt).Formula
ws.Range("G" & dt).Formula = ws.Range("Z" & dt).Formula
ws.Range("H" & dt).Formula = ws.Range("AA" & dt).Formula
ws.Range("I" & dt).Formula = ws.Range("AB" & dt).Formula
ws.Range("J" & dt).Formula = ws.Range("AC" & dt).Formula
ws.Range("K" & dt).Formula = ws.Range("AD" & dt).Formula
ws.Range("L" & dt).Formula = ws.Range("AE" & dt).Formula
ws.Range("M" & dt).Formula = ws.Range("AF" & dt).Formula
ws.Range("N" & dt).Formula = ws.Range("AG" & dt).Formula

Next cel


'''''''''''''''''''''''''' RISK '''''''''''''


End If
Next Sh


''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''

Range("B7:N10000").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N''''''''''''''''''''''''


''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''

Range("E7:N10000").Select
Application.CutCopyMode = False
Selection.Style = "Comma"
Selection.NumberFormat = _
"_-* #,##0.0 _€_-;-* #,##0.0 _€_-;_-* ""-""?? _€_-;_-@_-"
Selection.NumberFormat = "_-* #,##0 _€_-;-* #,##0 _€_-;_-* ""-""?? _€_-;_-@_-"


''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''

''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE


ThisWorkbook.Sheets("MODELE").Range("A3:M4").Copy
With ws.Range("B1:N10000")
For i = 7 To dt
If .Range("B" & i) <> "Totalazerty" And .Range("B" & i) <> "" Then
.Rows(i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Next i
End With


''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE

Range("P10").Select


End Sub