Macro Extraction de données et changement ordre de colonnes

Bonjour à tous,

Je débute en macro et j'essaie de créer un graphique rayon de soleil à partir des données d'un tableau excel. (Je ne peux pas le faire sous format de tableau croisé dynamique car il ne prend pas ce type de graphique en charge.)

Je cherche donc à faire pour chaque activité un onglet différent dans lequel je trouverai uniquement les données nécessaires à la réalisation du graphique.

Je n'ai donc besoin que des colonnes : RISQUE APRES REEVALUATION, ACTIVITE, RISQUES et SITUATION DE TRAVAIL. Or ces colonnes ne sont pas dans l'ordre de l'onglet à copier. De plus, je souhaite créer une colonne suplémentaire au tableau avec une valeur par défaut égale à 1.

J'ai réussi à créer automatiquement les onglets pour chacune de unités avec le code suivant :

Sub Données_Onglets()

'Création des feuilles automatiquement pour chaque service
For Each cell In Range("Liste_Unité")
Set feuille = Worksheets.Add(After:=Worksheets(Worksheets.Count))

feuille.Name = cell.Value

Next cell

End Sub

Pourriez-vous me donner des pistes pour compléter ma macro ?

Je vous remercie par avance pour votre aide.

Bonjour,

Ce code va te "copier-coller" tes données en feuille Feuil1 cellule A1.

Tu pourras l'adapter facilement.

Sub Copier_Coller()
Dim ListObj As ListObject, Colonnes As Variant, Tabl_Out(), i As Long
    Colonnes = Array("RISQUE APRES REEVALUATION", "ACTIVITE", "RISQUES", "SITUATION DE TRAVAIL")
    Set ListObj = getListObject("Tableau1", ThisWorkbook)   'ton tableau en feuille Données s'appelle Tableau1 *** A ADAPTER ***
    If Not ListObj Is Nothing Then                          'si tableau structuré trouvé
        Tabl_Out = getPartialArray(ListObj, Colonnes)       'extrait les colonnes
        ReDim Preserve Tabl_Out(LBound(Tabl_Out, 1) To UBound(Tabl_Out, 1), LBound(Tabl_Out, 2) To UBound(Tabl_Out, 2) + 1)
        For i = LBound(Tabl_Out) To UBound(Tabl_Out)
            Tabl_Out(i, UBound(Tabl_Out, 2)) = 1                              'complète les valeurs par défaut = 1
        Next
    Else
        MsgBox "Tableau non trouvé"
    End If
    'COLLE LES DONNEES EN A1 Feuil1 ************ A ADAPTER *******************
    Worksheets("Feuil1").Range("A1").Resize(UBound(Tabl_Out, 1), UBound(Tabl_Out, 2)) = Tabl_Out
End Sub

Function getListObject(Name As String, Optional Wbk As Workbook) As ListObject
'Fonction qui retourne un Objet "ListObject" en fonction de son nom, dans toutes les feuilles du classeur.
'Nothing si non trouvé
Dim Wsh As Worksheet, lCounter As Long
    If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
    For Each Wsh In Wbk.Worksheets
        lCounter = 1
        Do While lCounter <= Wsh.ListObjects.Count And getListObject Is Nothing
            If Wsh.ListObjects(lCounter).Name = Name Then Set getListObject = Wsh.ListObjects(lCounter)
            lCounter = lCounter + 1
        Loop
    Next Wsh
End Function
Function getPartialArray(Lo As ListObject, Columns) As Variant
'Transfert de certaines colonnes de tableau structuré vers variable tableau
'https://www.developpez.net/forums/d2091033/logiciels/microsoft-office/excel/transfert-certaines-colonnes-tableau-structure-vers-variable-tableau/#post11618243
Dim temp, r As Long, C As Long
    If Lo.ListRows.Count > 0 Then
        temp = Lo.DataBodyRange.Value
        ReDim T(1 To UBound(temp), 1 To UBound(Columns) + 1)
        For r = 1 To UBound(temp)
            For C = 0 To UBound(Columns)
                T(r, C + 1) = temp(r, Lo.ListColumns(Columns(C)).Index)
            Next C
        Next r
        getPartialArray = T
    End If
End Function

Bonjour,

Merci beaucoup pour ce retour, ça m'est d'une grande aide.

Je vais maintenant essayer d'extraire, après avoir créer un nouvel onglet pour chaque unité, uniquement les données liées à cette unité.

Savez-vous s'il est possible d'ajouter des nouvelles lignes automatiquement lorsque l'on rajoute des lignes dans l'onglet "données" ?

Ou dois-je obligatoirement supprimer les onglets précédemment créés pour en réaliser des nouveaux ?

Merci pour votre aide.