Transposition assez complexe de donneés

Bonjour Marc,

Merci pour ta réponse, et désolé de ne pas avoir répondu explicitement à ta question. Dans l'ensemble, je disais que vos deux codes n'ont pas fonctionné dans mon propre fichier.

Je joins donc un fichier avec ton code et tu vas remarquer l'erreur en cliquant sur le bouton "Transférer les données vers Compilation-Minéralogie". Pourrais-tu, stp, le vérifier sur mon fichier et me le retourner si ça fonctionne

L'idée après, c'est de cliquez sur le bouton "ajouter échantillon", une nouvelle fenêtre s'ouvre, je travaille sur de nouveau minéraux (colonne B4:B23) avec de nouvelles proportions (colonne D4:D23) et je clique de nouveau sur le bouton "Transférer les données vers Compilation-Minéralogie" pour compiler les données dans une même feuille (les données à copier viennent de B4:B23, D4:D23 et C31.

Voir l'exemple sur mon post du 23 ami 2015 à 23:58 et avec le fichier Excel nommé "Copie sélective des donnée vers une autre feuilles .xlsx"

MERCIIII

Pas de souci de mon côté avec le fichier joint précédent le post de mon code, d'où ma question !

Donc, si le test a réellement été effectué sur ce fichier, sans précision je ne vois rien et je passe la main …

Quant à l'autre proposition, je laisse son auteur répondre.

Merci Marc pour ta réponse.

EXcuse-moi de te harceler c'est mon incompétence .... Je t'ai demandé ce matin (post 16, 11:12) de faire un test avec mon fichier ou j'ai copié ton code mais j'ai oublié de le joindre. le voilà et je te demande juste un dernier essai STP. Cette solution me sera d'une aide extrêmement précieuse et surtout pour les étudiants à l'Université. La feuille fait partie d'un très gros fichiers qui constitue un outils de travail pédagogique qui profitera aux étudiants en mine...

Merci bcp et bonne soirée

Bonjour Marc L, Senlis, le forum

Evite de multiplier les posts, Senlis, je découvre à l'instant tes remarques.

Je ne pouvais pas être devant mon écran ayant des journées de travail très chargées en ce moment.

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
            If ws.Name Like "Réconciliation *" 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
    With Sheets("Compilation-Minéralogie").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(b, 2) - 1)
            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)
                .NumberFormat = "#,##0.00"
            End With
        End With
        .Columns.AutoFit: .Parent.Select
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Une alternative :

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
            If ws.Name Like "Réconciliation *" Then
                t = t + 1
                ReDim Preserve b(1 To UBound(b, 1), 1 To 1 + t)
                b(1, UBound(b, 2)) = ws.Range("C31").Value
                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
    Application.ScreenUpdating = False
    With Sheets("Compilation-Minéralogie").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        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)
                .NumberFormat = "#,##0.00"
            End With
        End With
        .Columns.AutoFit: .Parent.Select
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Dans mon code précédent, les commentaires en vert auraient dû te mettre la puce à l'oreille

Sinon si tu as de nouvelles demandes, il vaut mieux ouvrir une nouvelle discussion.

klin89

Bonoir Klin,

Désolé pour les tous les posts. C'est la première fois que je suis sur un forum et j'ignore les bonnes manières. Mes plus grandes excuses à tout le monde.

Merci pour ta réponse. J'ai copié les deux alternatives mais j'ai des message d'erreurs. Est ce que tu peux travailler stp sur mon fichier Excel joint et me le poster. Je suis sur que je fais quelques de faut en intégrant les codes dans mon classeur.

Merci et c'est la dernière fois que je vous sollicite et vous embête, toi et MarcL.

BONNE SOIRÉE et bonjour du Québec

Bonjour Marc et Klin, et tout le forum

Vous êtes géniaux les gars, c'est moi la tarte parmi vous... Je n'utilisais pas le code comme il faut. Je l'assignais à un bouton existant et au clic, j'avais toujours un message d'erreur au niveau de Sub...

Je suis parti d'un nouveau fichier, j'ai créé un nouveau module, collé le code et tout fonctionne par votre magie, je suis aux anges et vous avez vraiment fait mon bonheur MERCIIIIIIIIIIIIIIIIIII