Compilation des données de plusieurs feuilles vers une seule

Le 10/05/2019 à 09:13

Bonjour les amis

Je reviens encore vers vous pour une nouvelle demande d'aide sachant que j'ai été aidé dans toutes mes précédentes demandes et j'en remercie énormément la communauté de ce site.

ce dont j'ai besoin :

je génère des données d'un logiciel que je copie dans différentes feuilles excel (nombre de feuille variable) que je voudrais compiler dans une seule feuille. Je joins un fichier excel pour mieux illustrer ma demande.

je décrit mon besoin avec l'exemple:

1- de la feuille ech-1, copier les données des deux colonnes A et D, vers la feuille compilation.

2- faire pareil pour toutes les feuilles ech-2, ech-3 ... jusqu'à ech-9

3- dans la feuille compilation, il y aura une seule colonne A avec les entrées venant de la colonne A de chaque feuille, et les données de la colonne D venant de chaque feuille seront copiées dans des colonnes différentes de la feuille compilation comme le montre le fichier exemple joint.

On peut avoir plusieurs feuilles (dans cet exemple, il y a seulement 9 feuilles), et plusieurs entrées dans les colonnes A et D (ici 21, et il peut avoir bien plus).

Merci beaucoup pour votre précieuse aide.

Hassan.

16compilation-mineralogie.xlsx (34.30 Ko)
Le 10/05/2019 à 10:31

Bonjour senlis01

Avec ce que j'ai compris.

Il n'y a que des feuilles de type ech- et une feuille "Compilation".

Une proposition dont le résultat est à vérifier (je trouve un "Clinochlore" qui n'est pas dans ton exemple).

Cordialement

39compilation-mineralogie-2.xlsm (49.70 Ko)
Le 10/05/2019 à 11:44

Merci beaucoup Efgé

ça marche du premier coup, c'est trop génial. Vous ne pouvez pas imaginer combien ça me fera gagner de temps...

Merci encore infiniment. combien j'aimerai avoir vos compétences... comment puis-je faire pour y arriver

Cordialement

Le 10/05/2019 à 12:45

Rebonjour

Comme on dit, il faut taper le fer tant qu'il est chaud. Je viens donc avec une autre demande, plus ou moins semblable à la précédente : extraire toutes les données en lignes et en colonnes de chaque feuille (echa-1, echa-2, ... ect) et les mettre dans la seule feuille compilation.

Les explication sont dans le fichier Excel joint, c'est plus facile ainsi.

Merci pour votre précieuse aide

Hassan

12associations-mineralogie.xlsx (26.61 Ko)
Le 10/05/2019 à 12:49

Re

Là, je ne m'y frotte pas. Ca sent l'usine à gaz

Cordialement

Le 10/05/2019 à 13:18

Hahahaha, c'est du gaz pacifique efgé

ça devait être ma dernière requête et ce n'est pas pour un usage industriel. Je suis chercheur à l'Université et ce sont des données qui sortent d'un logiciel de microscopie et qui sont fastidieux à compiler. Ce que vous avez fait pour moi concernant le fichier précédent, est vraiment précieux et servira aussi les étudiants...

Merci

Hassan

Le 11/05/2019 à 16:37

Bonjour senlis01,

Salut Efgé

Pour ta deuxième demande, essaie ceci :

Option Explicit
Sub test()
Dim ws As Worksheet, dico As Object, AL1 As Object, AL2 As Object
Dim a, w, i As Long, j As Long, n As Long, e
    Set dico = CreateObject("Scripting.Dictionary")
    Set AL1 = CreateObject("System.Collections.ArrayList")
    Set AL2 = CreateObject("System.Collections.ArrayList")
    For Each ws In Worksheets
        If ws.Name <> "Compilation" Then
            a = ws.Cells(1).CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                If Not AL1.Contains(a(i, 1)) Then AL1.Add a(i, 1)
            Next
            For i = 2 To UBound(a, 2) - 1
                If Not AL2.Contains(a(1, i)) Then AL2.Add a(1, i)
            Next
        End If
    Next ws
    AL1.Sort: AL2.Sort: AL2.Add "Background"
    For Each ws In Worksheets
        If ws.Name <> "Compilation" Then
            ReDim w(1 To AL1.Count + 1, 1 To AL2.Count + 1)
            w(1, 1) = ws.Name
            For i = 0 To AL1.Count - 1
                w(i + 2, 1) = AL1(i)
            Next
            For j = 0 To AL2.Count - 1
                w(1, j + 2) = AL2(j)
            Next
            a = ws.Cells(1).CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                For j = 2 To UBound(a, 2)
                    w(AL1.IndexOf(a(i, 1), 0) + 2, AL2.IndexOf(a(1, j), 0) + 2) = a(i, j)
                Next
            Next
            dico(ws.Name) = w
        End If
    Next ws
    Application.ScreenUpdating = False
    With Sheets("Compilation").Range("a1")
        .Parent.Cells.Clear
        For Each e In dico.keys
            With .Offset(n).Resize(UBound(dico.Item(e), 1), UBound(dico.Item(e), 2))
                .Value = dico.Item(e)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Cells(1).Font.Bold = True
                With .Rows(1)
                    .Borders(xlEdgeBottom).Weight = xlThin
                    .HorizontalAlignment = xlCenter
                    With .Offset(, 1).Resize(, .Columns.Count - 1)
                        .Interior.ColorIndex = 43
                    End With
                End With
                With .Columns(1)
                    With .Offset(1).Resize(.Rows.Count - 1)
                        .Interior.ColorIndex = 19
                    End With
                End With
            End With
            n = n + UBound(dico.Item(e), 1) + 1
        Next
        With .Parent.UsedRange
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Set dico = Nothing: Set AL1 = Nothing: Set AL2 = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Le 11/05/2019 à 18:55

Bonjour à tous, Salut Klin

@ Klin

Content de te croiser

M'en vais m'pencher sur le "System.Collections.ArrayList" dont le ".sort" semble prometteur....

Cordialement

Le 12/05/2019 à 02:24

Bonsoir Klin89

Merci beaucoup pour ton code qui fonctionne très bien, J'en suis extrêmement heureux, et je dois t'en remercier surtout que ce n'est pas la première fois que tu m'aide dans ce genre de travail.

J'ai essayé le même code sur d'autres données du même genre, et j'ai remarqué qu'il m'ajoute une colonne nommée "backgroud" qui n'est pas dans les données, du coup les entrées de la colonne A sont erronées. J'attache un fichier exemple pour visualiser l'erreur.

Encore une fois, merci infiniment pour le premier code qui fonctionne très bien.

Salutations

Hassan

14donnees-iiberation-mineralogie.xlsm (28.66 Ko)
Le 12/05/2019 à 09:57

re senlis01,

Place la procédure dans un module standard et non pas dans un module de feuille.

Remplace :

For i = 2 To UBound(a, 2) - 1
    If Not AL2.Contains(a(1, i)) Then AL2.Add a(1, i)
Next

par

For i = 2 To UBound(a, 2)
    If Not AL2.Contains(a(1, i)) Then AL2.Add a(1, i)
Next

et

AL1.Sort: AL2.Sort: AL2.Add "Background"

par :

AL1.Sort

Pas besoin de trier AL2

Attention en feuil4, supprime la colonne A qui est vide

Le problème n'est plus tout à fait le même au final puisque que l'on retrouve les mêmes en-têtes de colonne dans toutes tes feuilles

klin89

Le 12/05/2019 à 20:38

re senlis01

Vu la nouvelle disposition de tes données, ceci suffit.

Option Explicit
Sub test()
Dim ws As Worksheet, dico As Object, AL As Object
Dim a, w, i As Long, j As Long, n As Long, e
    Set dico = CreateObject("Scripting.Dictionary")
    Set AL = CreateObject("System.Collections.ArrayList")
    For Each ws In Worksheets
        If ws.Name <> "Compilation" Then
            a = ws.Cells(1).CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                If Not AL.Contains(a(i, 1)) Then AL.Add a(i, 1)
            Next
        End If
    Next ws
    AL.Sort
    For Each ws In Worksheets
        If ws.Name <> "Compilation" Then
            a = ws.Cells(1).CurrentRegion.Value
            ReDim w(1 To AL.Count + 1, 1 To UBound(a, 2))
            w(1, 1) = ws.Name
            For i = 0 To AL.Count - 1
                w(i + 2, 1) = AL(i)
            Next
            For j = 2 To UBound(a, 2)
                w(1, j) = a(1, j)
            Next
            For i = 2 To UBound(a, 1)
                For j = 2 To UBound(a, 2)
                    w(AL.IndexOf(a(i, 1), 0) + 2, j) = a(i, j)
                Next
            Next
            dico(ws.Name) = w
        End If
    Next ws
    Application.ScreenUpdating = False
    With Sheets("Compilation").Range("a1")
        .Parent.Cells.Clear
        For Each e In dico.keys
            With .Offset(n).Resize(UBound(dico.Item(e), 1), UBound(dico.Item(e), 2))
                .Value = dico.Item(e)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Cells(1).Font.Bold = True
                With .Rows(1)
                    .Borders(xlEdgeBottom).Weight = xlThin
                    .HorizontalAlignment = xlCenter
                    With .Offset(, 1).Resize(, .Columns.Count - 1)
                        .Interior.ColorIndex = 43
                    End With
                End With
                With .Columns(1)
                    With .Offset(1).Resize(.Rows.Count - 1)
                        .Interior.ColorIndex = 19
                    End With
                End With
            End With
            n = n + UBound(dico.Item(e), 1) + 1
        Next
        With .Parent.UsedRange
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Set dico = Nothing: Set AL = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Le 12/05/2019 à 22:59

Merci Infiniment Kiln, ça marche bien avec la modification que tu suggère. C'est super génial

Mission accomplie

Rechercher des sujets similaires à "compilation donnees feuilles seule"