XL 2016 Regroupement plusieurs onglets en un seul

[rmjunivers]

Bonjour la grande famille,
j'ai un fichier Excel qui a 43 onglets avec des informations enregistrées sous le même modèle.
je souhaite regrouper automatiquement les informations de ces 43 onglets dans un onglet récapitulatif...
prière de m'aider svp

 

[dubarre]

Bonjour pour que nous puissions voir plus précisément ce que tu souhaites que tu nous mettre un fichier exemple s'il te plaît

 

[rmjunivers]

bonjour,
voici le fichier.

 

[escouger]

Bonjour,
Veux-tu mettre bout à bout les 43 onglets dans l'objet Recap, ou existe-t-il un critère à rapprocher dans les différents onglets?

 

[JHA]

Bonjour à tous,

Un essai avec Power Query mais je ne suis pas familier avec cet éditeur.

JHA

 

[kiki29]

Salut, sans PQ, à tester

Spoiler

Option Explicit

Sub FusionFeuilles()
Dim i As Long, T() As Variant

    Application.ScreenUpdating = False
    If shRecap.FilterMode Then shRecap.ShowAllData
    shRecap.Cells.Clear

    ' En-Tête
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> shRecap.Name And _
           Worksheets(i).Name <> shMrc.Name And _
           Worksheets(i).Name <> Feuil1.Name Then
            With Worksheets(i)
                T = .Range("A1:G1").Value
                shRecap.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
            Exit For
        End If
    Next i

    '   Données
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> shRecap.Name And _
           Worksheets(i).Name <> shMrc.Name And _
           Worksheets(i).Name <> Feuil1.Name Then
            With Worksheets(i)
                If .FilterMode Then .ShowAllData
                LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                If LastRow > 1 Then
                    T = .Range("A2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
                    shRecap.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T
                End If
            End With
        End If
    Next i

    With shRecap
        .Activate
        .Range("K1").Select
    End With

    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

    Erase T
    Application.ScreenUpdating = True
End Sub

shRecap, shMrc, Feuil1 sont les CodeNames des feuilles Recap, Mrc et de la feuille cachée Feuil1.
Resterait à ajouter une procédure de suppression des doublons ( j'en trouve 54 ? )

 

[rmjunivers]

Bonjour,
Veux-tu mettre bout à bout les 43 onglets dans l'objet Recap, ou existe-t-il un critère à rapprocher dans les différents onglets?

au final je voudrais avoir les 43 onglets

dans l'objet Recap​

 

[rmjunivers]

Salut, sans PQ, à tester

Option Explicit

Sub FusionFeuilles()
Dim i As Long, T() As Variant

    Application.ScreenUpdating = False
    shRecap.Range("A1:G" & Rows.Count).Clear

    ' En-Tête
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> shRecap.Name And _
           Worksheets(i).Name <> shMrc.Name And _
           Worksheets(i).Name <> Feuil1.Name Then
            With Worksheets(i)
                T = .Range("A1:G1").Value
                shRecap.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
            Exit For
        End If
    Next i

    '   Données
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> shRecap.Name And _
           Worksheets(i).Name <> shMrc.Name And _
           Worksheets(i).Name <> Feuil1.Name Then
            With Worksheets(i)
                T = .Range("A2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
                shRecap.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
        End If
    Next i

    With shRecap
        .Activate
        .Range("K1").Select
    End With

    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

    Erase T
    Application.ScreenUpdating = True
End Sub

shRecap, shMrc, Feuil1 sont les CodeNames des feuilles Recap,mrc et de la feuille cachée Feuil1.
Resterait à ajouter une procédure de suppression des doublons ( j'en trouve 54 ? )

merci beaucoup pour votre précieuse aide.

 

[chris]

Bonjour à tous

Un essai avec Power Query mais je ne suis pas familier avec cet éditeur.

il suffit de nommer chaque tableau avec un nom commençant par un préfixe donné, par exemple T_ et une seule requête suffit : elle intégrera automatiquement tout nouveau tableau dont le nom est ainsi préfixé
Je me suis contenté de mettre sous forme de tableau les 6 premiers.
Il suffit de continuer puis d'actualiser pour mettre à jour la synthèse

On pourrait ajouter un tri à la requête

@ JHA : il est préférable de travailler sur le classeur courant plutôt que sur le fichier : pas de problème de chemin ni de décalage entre état courant et dernière sauvegarde
Sinon tu peut aussi faire de même sur un fichier externe : une seule requête.

 

[kiki29]

Salut, pour générer les tableaux utilisables par PQ 2 moulinettes à ajouter au fichier Fusion XLD 02.zip posté ci-dessus

Il en faudrait une autre pour définir les zones d'impression.
Il faudrait également nettoyer certaines feuilles : lignes vides, format discordant des N° de tel, contenu incohérent de certaines cellules ( notamment téléphones ), polices différentes sur les mêmes feuilles, etc.

Pour les doublons il suffit d'insérer à l'endroit idoine dans la procédure FusionFeuilles

Spoiler

    If bSupp Then
        LastRow = shRecap.Range("A" & Rows.Count).End(xlUp).Row
        shRecap.Range("$A$2:$G$" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
    End If

bSupp étant une variable booléenne liée à une checkbox via

bSupp = shRecap.CheckBoxes("chkDoublons").Value = 1

Les 2 moulinettes :

Option Explicit

Const sTablo = "Tableau_"

Sub Moulinette_NommageTableaux()
Dim i As Long, j As Long
Dim LastRow As Long
Dim Deb As Currency

    Application.ScreenUpdating = False
    Application.StatusBar = ""
    Deb = Timer

    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> shRecap.Name And _
           Worksheets(i).Name <> shMrc.Name And _
           Worksheets(i).Name <> Feuil1.Name Then
            With Worksheets(i)
                If .FilterMode Then .ShowAllData
                j = j + 1
                LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                ActiveWorkbook.Names.Add Name:=sTablo & Format(j, "000"), RefersToR1C1:="='" & Worksheets(i).Name & "'!R2C1:R" & LastRow & "C7"
                .Activate
                With ActiveWindow
                    .ScrollRow = 1
                    .SplitColumn = 0
                    .SplitRow = 1
                    .FreezePanes = True
                End With
                .Range("H1").Select
                If LastRow > 1 Then
                    .Range("A1:G" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=False
                    Selection.AutoFilter
                End If
            End With
        End If
    Next i

    shRecap.Select

    Application.StatusBar = "Terminé : " & Format(Timer - Deb, "0.00 s")
    Application.ScreenUpdating = True
End Sub

Sub Moulinette_SuppressionNomsTableaux()
Dim n As Name
    For Each n In ActiveWorkbook.Names
        If InStr(n.Name, sTablo) > 0 Then n.Delete
    Next n
End Sub