Transposition assez complexe de donneés

Bonjour tout le monde.

Je suis chargé de cours dans une université et j'ai monté un fichier Excel pour des calculs de minéralogie comme outils pédagogiques pour les étudiants (sans but lucratif). Pour e fichier, j'utilise une base de données qui m'a été gracieusement donnée par un site web des plus connus dans le domaine (webmineral). Le fichier que j'ai reçu de webmineral contient les données dans une disposition très difficile à exploiter dans mon fichier que j'ai écris grâce à des sites web comme le votre. Mon problème est très bien expliqué dans le fichier Excel que je joints à ma question. Je fais confiance au têtes très douées de e forum pour m'aider un écrire à petit programme VBA ou un macro pour transposer les informations disposées en ligne vers des colonnes.

Je vous remercie infiniment et j'ajouterai dans mon fichier un lien vers votre site si j'au une solution. Tous les étudiants qui auront à utiliser e fichier vous en remercieront aussi.

Salutations

Hassan BOUZAHZAH, Ph.D

chercheur et chargé de cours

Bonjour,

Un premier jet à tester

A+

Bonjour,

la dernière fois que j'ai eu affaire à l'UQAT de la Belle Province, un étudiant cherchant à faire faire son devoir …

Edit : Après contact, l'émetteur est bien le professeur, pas de souci cette fois …

Bonsoir frangy, Marc L, Senlis, le forum

J'ai traité la transposition.

A tester, résultat en Feuil3.

Option Explicit

Sub Multi_Tableaux()
Dim a, i As Long, j As Long, w, x, y, n As Long
    With Sheets("Base de données").Cells(1).CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 3, 4, 5, 6, 2, 7))
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To 7, 1 To 2)
                For j = 1 To 7
                    w(j, 1) = a(1, j)
                    w(j, 2) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
                For j = 1 To 7
                    w(j, UBound(w, 2)) = a(i, j)
                Next
            End If
            .Item(a(i, 1)) = w
        Next
        x = .keys: y = .items
    End With
    Application.ScreenUpdating = False
    With Sheets("Sheet3").Range("a1")
        .Parent.UsedRange.Clear
        n = 1
        For i = 0 To UBound(x)
            With .Cells(n + 1, 1)
                .Resize(UBound(y(i), 1), UBound(y(i), 2)).Value = y(i)
                With .CurrentRegion
                    With .Rows(1)
                        .Interior.ColorIndex = 39
                        .BorderAround Weight:=xlThin
                    End With
                    .Columns(1).Cells(6).Interior.ColorIndex = 44
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                End With
            End With
            n = n + UBound(y(i), 1) + 1
        Next
        With .Parent.UsedRange
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

Je n'ai pas compris le résultat souhaité dans la partie haute de ton tableau, je passe mon tour sur ce coup là

klin89

21senlis.zip (56.33 Ko)

Je viens d'éditer mon précédent message …

J'attends le retour du demandeur quant à la proposition de Frangy.

Re le forum,

Résultat en Feuil3

Le code dans le module 2.

Option Explicit

Sub Ventile()
Dim a, b, i As Long, j As Byte, n As Long, t As Long, dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    a = Sheets("Base de données").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To 5)
    n = 1: b(1, 1) = "Nom mineral": b(1, 2) = "Formule"
    b(1, 3) = "Famille": b(1, 4) = "Masse molaire": b(1, 5) = "Gs"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                n = n + 1: dico(a(i, 1)) = n
                b(n, 1) = a(i, 1)
                For j = 2 To 5
                    b(n, j) = a(i, j + 1)
                Next
            End If
            If Not .exists(a(i, 2)) Then
                t = t + 1: .Item(a(i, 2)) = t
                ReDim Preserve b(1 To UBound(a, 1), _
                                 1 To UBound(b, 2) + 1)
                b(1, t + 5) = a(i, 2)
            End If
            b(dico(a(i, 1)), .Item(a(i, 2)) + 5) = a(i, 7)
        Next
    End With
    With Sheets(3).Cells(1).Resize(n, UBound(b, 2))
        .Parent.UsedRange.Clear
        '.CurrentRegion.Clear
        .Value = b
        With .CurrentRegion
            With .Offset(1, 5).Resize(.Rows.Count - 1, .Columns.Count - 5)
                .NumberFormat = "#,##0.00"
            End With
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .RowHeight = 21
                .Font.Size = 11
                .Interior.ColorIndex = 6
                .BorderAround Weight:=xlThin
                With .Offset(, 5).Resize(, .Columns.Count - 5)
                    .Interior.ColorIndex = 43
                    .Font.ColorIndex = 2
                End With
            End With
            .Columns.AutoFit
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

16senlis1.zip (70.30 Ko)
16senlis1.zip (70.30 Ko)

Re,

Tant qu'à faire, c'est mieux sans Redim Preserve

Le code dans le module 3.

Option Explicit

Sub Ventile_1()
Dim a, i As Long, j As Long, b(), n As Long, t As Long
Dim dico As Object
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Base de données").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To 5 + UBound(a, 1) - 1)
    t = 5: n = 1
    b(1, 1) = a(1, 1): b(1, 2) = a(1, 3): b(1, 3) = a(1, 4)
    b(1, 4) = a(1, 5): b(1, 5) = a(1, 6)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                For j = 2 To 5
                    b(n, j) = a(i, j + 1)
                Next
                .Item(a(i, 1)) = n
            End If
            If Not dico.exists(a(i, 2)) Then
                t = t + 1
                b(1, t) = a(i, 2)
                dico(a(i, 2)) = t
            End If
            b(.Item(a(i, 1)), dico(a(i, 2))) = a(i, 7)
        Next
    End With
    With Sheets(3).Cells(1).Resize(n, t)
        .Parent.UsedRange.Clear
        '.CurrentRegion.Clear
        .Value = b
        With .CurrentRegion
            With .Offset(1, 5).Resize(.Rows.Count - 1, .Columns.Count - 5)
                .NumberFormat = "#,##0.00"
            End With
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .RowHeight = 21
                .Font.Size = 11
                .Interior.ColorIndex = 29
                .Font.ColorIndex = 2
                .BorderAround Weight:=xlThin
                With .Offset(, 5).Resize(, .Columns.Count - 5)
                    .Interior.ColorIndex = 23
                End With
            End With
            .Columns.AutoFit
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour,

Merci infiniment Klin89. Ton code a très bien fonctionné et je t'en remercie infiniment. Ma base de données de 4300 minérales est fonctionnelle dans la disposition que je voulais C'EST TROP GÉNIALE, vraiment Merciiiiiiiii . Je réponds un peu tardivement car c'est seulement ce matin que j'ai pu tout tester.

J'ai une autre demande après avoir cherché longtemps des solutions et sans arriver à adapter les codes trouvés, donc je me retourne vers vous:

L'exemple se trouve sur le fichier joint et tout est bien expliqué.

Bonjour,

dans le classeur réel, quelle est l'adresse de la cellule du premier titre du tableau - Liste des minéraux - de la feuille Compilation ?

Sinon il est possible d'effacer l'intégralité de la feuille pour effectuer la compilation …

Les données des feuilles de réconciliation sont toujours classées à l'envers ?

Pas de souci pour des tableaux d'une vingtaine de lignes …

Voici une démonstration vers la Feuil4 vierge de tout dessin :

Sub Demo()
Dim TE(1 To 61, 1 To 3), TM$(1 To 61, 0)
                L% = 1:  TM(1, 0) = "Liste des minéraux"
For C% = 1 To 3
    With Worksheets(C):  TE(1, C) = .[C31].Value:  VA = .[B4:D23].Value:  End With

    For R% = 20 To 1 Step -1
        If VA(R, 1) > "" Then
            V = Application.Match(VA(R, 1), TM, 0)
            If IsError(V) Then L = L + 1: TM(L, 0) = VA(R, 1): V = L
            TE(V, C) = VA(R, 3)
        End If
    Next R
Next C

With Feuil4
    .UsedRange.Clear

    With .[B2].Resize(L, 4)
         .Rows(2).Resize(L - 1).IndentLevel = 1
                         .Borders.LineStyle = xlContinuous
                          .Columns(1).Value = TM

         With .Columns("B:D")
             With .Rows(2).Resize(L - 1)
                  .HorizontalAlignment = xlRight
                         .NumberFormat = "#,##0.00"
             End With

             .Value = TE
         End With

         .Columns.AutoFit
    End With
End With
End Sub

Bonjour Marc,

Merci beaucoup pour ta réponse. Pour répondre à tes questions :

Ta question :

dans le classeur réel, quelle est l'adresse de la cellule du premier titre du tableau - Liste des minéraux - de la feuille Compilation ?

Réponse :

L'exemple de mon fichier posté représente exactement les feuilles sur lesquelles je vais travailler et les cellules ont exactement les mêmes adresses. Rien ne vas changer dans mon fichier final.

Ta question :

Les données des feuilles de réconciliation sont toujours classées à l'envers ?

Réponse :

Je commence à remplir d'abord la case B23 et je monte à la case B4 en fonction du nombre de minéraux à traiter. Je fais ainsi pour pouvoir masquer les premières lignes (voir fichier) et gagner de l'espace pour visualiser un graphique qui se placera en bas par manque de place dans mon petit écran. Dans la feuille qui recevra les données, peu importe dans quel ordre les infos seront enregistrées : soit de la case B4 à B23 et D4 à D23 quitte à avoir les premières cases vides, ou l'inverse.

Enfin, j'ai essayé le code que tu m'as envoyé et ça ne me donne rien. J'ai créé un nouveau module, copié ton code et je l'ai lancé ça bute sur la ligne .UsedRange.Clear

Merci beaucoup pour ton aide mon cher et au plaisir d'avoir un code qui me facilitera la vie

Have a nice day

Salutations

Hassan BOUZAHZAH Ph.D

De mon côté le code produit bien le tableau escompté avec le fichier joint Copie selective !

« ça bute » : oui mais en clair ? Vu que je ne rencontre pas de souci, c'est par trop vague …

Merci Marc pour ta réponse.

J'ai réésayé avec ton code et je n'ai aucun résultats. Est ce que, stp, tu peux envoyer ton fichier excel avec le code implémenté. Je suis très débutant et néophyte. J'ai appris juste sur internet et je m'y interesse (VBA) depuis seulement une semaine.

MERCIIIIIIIIII

Bonsoir Marc L, Senlis, le forum

A tester :

Option Explicit

Sub Echantillon()
Dim ws As Worksheet, a, i As Long
Dim txt As String, b, n As Long, t As Long
    Application.Calculation = xlCalculationManual
    ReDim b(1 To 100000, 1 To 1): n = 1
    b(1, 1) = "Liste des numéraux"
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each ws In Worksheets
            'attention à la condition ci-dessous
            'je prends en compte toutes les feuilles
            'sauf la feuille "Compilation-Minéralogie" et la feuille de restitution
            If ws.Name <> "Compilation-Minéralogie" And ws.Name <> "Feuil1" Then
                t = t + 1
                ReDim Preserve b(1 To UBound(b, 1), 1 To 1 + t)
                a = ws.Range("b23").CurrentRegion.Columns(2).SpecialCells(2, 2).Resize(, 3).Value
                For i = UBound(a, 1) To 1 Step -1
                    txt = a(i, 1)
                    If Not .exists(txt) Then
                        n = n + 1: .Item(txt) = n
                        b(n, 1) = a(i, 1)
                    End If
                    b(.Item(txt), UBound(b, 2)) = a(i, 3): txt = ""
                Next
            End If
        Next
    End With
    b(1, 2) = "Echantillon1"
    Application.ScreenUpdating = False
    'Pour l'exemple restitution dans la cinquième feuille créée manuellement
    'Position dans le classeur
    With Sheets(5).Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        If UBound(b, 2) > 2 Then
            With .Offset(, 1).Resize(1, 1)
                .AutoFill .Resize(, UBound(a, 2))
            End With
        End If
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .Cells(1).Interior.ColorIndex = 6
                With .Offset(, 1).Resize(, .Columns.Count - 1)
                    .Interior.ColorIndex = 43
                    .Font.ColorIndex = 2
                End With
            End With
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .Select
                .NumberFormat = "#,##0.00"
            End With
        End With
        .Columns.AutoFit: .Parent.Select
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Je pense que l'on rencontrera des problèmes avec l'affectation suivante : la plage prise en compte pour chaque feuille.

a = ws.Range("b23").CurrentRegion.Columns(2).SpecialCells(2, 2).Resize(, 3).Value

Idem si certaines feuilles ne contiennent aucune données.

klin89

Bonjour Klin89 et Marc,

Merci Klin pour le code. Il a fonctionné une fois, et pour les autres tentatives, le code s'arrête à la ligne :

a = ws.Range("b23").CurrentRegion.Columns(2).SpecialCells(2, 2).Resize(, 3).Value

Quand je lis les codes, ça donne mal à la tête et me fait sentir tout minus Vous êtres des pros les gars

Je vais redéfinir légèrement mon besoin:

Dans mon fichier Excel de travail ou je veux intégrer le code, je peux avoir une seule feuille nommée "Réconciliation 1" quand je travaille avec une seule roche. Une fois mes calculs terminés, je voudrais par un clic de bouton transférer les résultats des cellules B4:B23, D4:D23 et C31 à la feuille "Compilation-Minéralogie".

Le plus souvent, on travaille sur plusieurs roches et échantillons et je peux avoir à dupliquer la feuille "Réconciliation 1" jusqu'à 10, 15, 20... fois et il serait pratique que de chaque nouvelle feuille de réconciliation, le clic du bouton me transfère les résultats vers LA MEME feuille "Compilation-Minéralogie" pour avoir une sorte de rapport.

Senlis a écrit :

J'ai réésayé avec ton code et je n'ai aucun résultats.

Mon code a-t-il bien été testé avec ton classeur joint nommé Copie selective …

En clair : ouvrir ce classeur là (car le code a été créé pour lui et pas un autre !), recopier mon code (effacer l'ancien) et le lancer …

Bonsoir,

Je suis sincèrement désolé de vous déranger avec mes histoires, mais ça ne fonctionne pas chez moi. Je vous envoie mon fichier test réduit car mon fichier de travail est trop volumineux.

J'ai ajouté un bouton nommé "transférer les données" contenant le code de Klin89.

Merci pour votre aide les gars

Salutation du Québec

Bonjour Marc et Klin89,

Avez-eu le temps de regarder mon dernier fichier posté hier (voir mon post précédent)

Et merci infiniment

Bonjour Marc et Klin89,

Je vous re-sollicite les gars pour voir si vous avez-eu le temps de regarder mon dernier fichier posté avec le code que vous m'aviez écris, mais non fonctionnel dans mon fichier (dont je joins une nouvelle version).

Et merci infiniment... Je vous assure que j''y travaille depuis 3 jours pour apprendre car je suis en congé de maladie et j'apprends beaucoup dans votre forum, mais incapable de faire seule cette copie complexe de données

Merci

Sans réponse à ma question …

Mais ne rencontrant pas de souci de mon côté …

Rechercher des sujets similaires à "transposition assez complexe donnees"