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,
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
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
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
J'ai une autre demande
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
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é …