Compiler les données de deux feuilles
Bonsoir Klin89 et mafraise
Je viens de tester vos deux codes sur de nouvelles données qui ont été acquises ce WE. j'ai 17 feuilles de doonées. Curieusement, vos deux codes retournent des erreurs quand il y a plus de 11 feuiles de données. donc quand j'enlève la série de feuille en bleau dans l'exemple joint, le code fonctionne. J'ai fait plusieurs tests en modifiant les feuilles, mais les deux codes bloquent à la 12emem feuille. Je ne sais pas ce que je fait comme erreur.
Je vous mets en copie mon fichier avec les 17 feuilles de données
@Klin89 : j'ai pu installer le .NetFramework 3.5, et l'erreur que j'avais était résolue.
Merci pour votre aide
Bonjour senlis01
Si deux codes radicalement différents s'arrêtent sur une erreur au même endroit, c'est que la cause ne provient pas des codes mais vraisemblablement des données.
Et en effet toutes les feuilles de type G9999 avec un onglet bleu ont leurs trois premières colonnes (colonnes A, B et C) qui sont vides. Nos codes ne le prévoient pas.
Supprimez ces trois colonnes des feuilles avec un onglet bleu et tout rentrera dans l'ordre.
...
nota : mon code suppose l'existence des feuilles "Compilation" et "Pivot Association". Si vous désirez que le code crée ces feuilles si elles sont absentes, demandez le moi !
Ne le demandez plus ! Je l'ai fait dans le classeur joint. La feuille menu facultative puisqu'on peut lancer directement les macros : COMPILATION(), PIVOT() ou TOUTES().
Bonjour à tous.
Je viens de tester les deux codes et ils fonctionnent tous les deux après avoir corrigé l'erreur dans mes données. Je n'ai pas fait attention que les colonnes étaient décalées dans les feuilles colorées en bleu. Je me disais bien que c'était curieux que les deux codent renvoie une erreur à cause des feuilles colorées en bleu. Maintenant, tout fonctionne à la perfection et je vous remercie infiniment pour votre très très précieuse aide. ça me fait gagner un temps précieux. Ce qui me prenait des heures à compiler, maintenant, un simple clic et la magie opère, votre magie
Je ne sais pas si j'abuse, mais j'ai un autre fichier qui contient un autre type de données (quantité des minéraux) qu'il faut copier et formater de la même manière que le fichier association que vous m'aviez aidé à faire.
Je vous mets en copie mon fichier et les instructions (en rouge) se trouvent dans la feuille "G1450" et la feuille "Mineralogie Compilation".
Merci pour votre précieuse aide.
Re senlis01,
Dans la nouvelle compilation, on ne retrouve pas les 2 termes "Not Analysed" et "Unclassified" que l'on peut retrouver dans les feuilles sources Gxxx, faut-il les omettre et faut-il à nouveau faire un tri alphabétique ?
Avec Power Query ça doit être facilement réalisable, JFL reviens 🙃
klin89
Bonjour Kiln89
Merci pour votre réactivité ;-)
Oui, il faut ometre les 2 termes "Not Analysed" et "Unclassified" que l'on peut retrouver dans les feuilles sources Gxxx, et tu as bien compris qu'il faut un tri alphabétique ?
Cool tout ça ;-)
Bonsoir senlis01
Voici une première version pour réorganiser les données de minéralogie.
Comme demandé, les valeurs sources ont été converties en nombres à deux chiffres après la virgule (ce n'est pas un simple formatage des nombres!)
...
Re à tous,
Avec le fichier du mardi 25 février à 11h23
Option Explicit
Sub Compilation1()
Dim a, b, e, i As Long
Dim Al As Object
Dim tbl(), ws As Worksheet, feuilles
Set Al = CreateObject("System.Collections.ArrayList")
b = Sheets("Ref échantillons").Range("A1").CurrentRegion.Value
feuilles = Application.Index(b, 3, Evaluate("ROW(2:" & UBound(b, 2) & ")"))
For Each e In feuilles
Set ws = Nothing
On Error Resume Next
Set ws = Sheets(e)
On Error GoTo 0
If Not ws Is Nothing Then
a = ws.Range("A1").CurrentRegion.Value
For i = 2 To UBound(a, 1) ' On parcourt la 1ère colonne
If Not Al.Contains(a(i, 1)) Then
Al.Add a(i, 1)
End If
Next
End If
Next
Al.Remove "Unclassified": Al.Remove "Not Analysed"
Al.Sort
ReDim tbl(1 To Al.Count + 1, 1 To 1)
For i = 0 To Al.Count - 1
tbl(i + 2, 1) = Al(i)
Next
For Each e In feuilles
Set ws = Nothing
On Error Resume Next
Set ws = Sheets(e)
On Error GoTo 0
If Not ws Is Nothing Then
a = ws.Range("A1").CurrentRegion.Value
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) + 1)
tbl(1, UBound(tbl, 2)) = e
For i = 2 To UBound(a, 1)
If Al.Contains(a(i, 1)) Then
tbl(Al.IndexOf(a(i, 1), 0) + 2, UBound(tbl, 2)) = a(i, 4)
End If
Next
End If
Next
Application.ScreenUpdating = False
If Not Evaluate("isref('Compilation2'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Compilation2"
With Sheets("Compilation2")
With .Cells(1)
.CurrentRegion.Clear
.Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.HorizontalAlignment = xlCenter
.Font.Size = 11
.BorderAround Weight:=xlThin
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 44
End With
End With
With .Columns(1)
With .Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 42
End With
End With
With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
.NumberFormat = "0.00"
End With
End With
End With
End With
Set Al = Nothing
Application.ScreenUpdating = True
MsgBox "Données rassemblées avec succès !", vbInformation
End SubLa suite, plus tard quand j'aurai un peu de temps
klin89
Bonjour les pros et passionnés du VBA.
Tout d'abord, désolé de revenir avec un peu de retard pour mon feedback sur vos codes. J'ai eu des journées pas mal très chargées.
C'est vraiment excellent car j'ai essayé avec de nouveaux résultats (17 feuilles) et ça fonctionne à merveille. Je suis vraiment très content du résultats et je ne sais comment vous remercier. ça me fait gagner un temps énorme les deux codes que vous m'aviez faits.
Comme on dit, jamais deux sans trois
Je vous souhaite un excellent WE et encore milles merci
Hassan
Re,
Toujours avec le fichier du mardi 25 février à 11h23
Option Explicit
Sub Pivot()
Dim a, b, e, pos, index
Dim i As Long, n As Long
Dim Al As Object
Dim tbl(), ws As Worksheet, feuilles
Dim cell As Range, currentValue As String, previousValue As String
' Initialisation de l'ArrayList
Set Al = CreateObject("System.Collections.ArrayList")
' Récupération des noms de feuilles à parcourir
b = Sheets("Ref échantillons").Range("A1").CurrentRegion.Value
feuilles = Application.index(b, 3, Evaluate("ROW(2:" & UBound(b, 2) & ")"))
' Remplissage de l'ArrayList avec les valeurs uniques de la colonne 1 des feuilles
For Each e In feuilles
Set ws = Nothing
On Error Resume Next
Set ws = Sheets(e) ' Vérification de l'existence de la feuille
On Error GoTo 0
If Not ws Is Nothing Then
a = ws.Range("A1").CurrentRegion.Value
For i = 2 To UBound(a, 1) ' On parcourt la 1ère colonne (sans l'en-tête)
If Not Al.Contains(a(i, 1)) Then
Al.Add a(i, 1)
End If
Next
End If
Next
' Suppression des valeurs spécifiques
Al.Remove "Unclassified": Al.Remove "Not Analysed"
Al.Sort ' Tri de l'ArrayList
' Initialisation du tableau tbl
ReDim tbl(1 To 5, 1 To 1) ' Tableau avec 5 colonnes et 1 ligne
tbl(1, 1) = "Ref GeMMe": tbl(2, 1) = "Flux": tbl(3, 1) = "Nom échantillon"
tbl(4, 1) = "Minéraux": tbl(5, 1) = "Concentration"
n = 2 ' Ligne de départ dans tbl
For Each e In feuilles
Set ws = Nothing
On Error Resume Next
Set ws = Sheets(e) ' Vérification de l'existence de la feuille
On Error GoTo 0
If Not ws Is Nothing Then
a = ws.Range("A1").CurrentRegion.Value
pos = Application.Match(e, Application.index(b, 3, 0), 0)
' Ajustement dynamique de la deuxième dimension (nombre de lignes)
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) + Al.Count)
' Remplissage des colonnes
For i = 0 To Al.Count - 1
tbl(1, n + i) = e ' Nom de la feuille
tbl(2, n + i) = b(1, pos) ' Flux
tbl(3, n + i) = b(2, pos) ' Nom echantillon
tbl(4, n + i) = Al(i) ' Valeurs de l'ArrayList
' Recherche et correspondance avec `a`
index = Application.Match(Al(i), Application.index(a, 0, 1), 0)
If Not IsError(index) Then
tbl(5, n + i) = a(index, 4) ' Valeurs correspondantes
End If
Next
n = n + Al.Count ' Mise à jour de l'index de ligne pour la prochaine feuille
End If
Next
' Restitution et mise en forme
Application.ScreenUpdating = False
If Not Evaluate("isref('Pivot_Mineraux'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = "Pivot_Mineraux"
With Sheets("Pivot_Mineraux")
With .Cells(1)
.CurrentRegion.Clear
If n > 0 Then
.Resize(UBound(tbl, 2), UBound(tbl, 1)).Value = Application.Transpose(tbl)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.Columns(5).NumberFormat = "0.00"
With .Rows(1)
.HorizontalAlignment = xlCenter
.Font.Size = 11
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 44
End With
.Columns.AutoFit
previousValue = .Cells(2, 1).Value
' Boucle à travers les lignes à partir de la deuxième
For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1)
currentValue = cell.Value
' Vérifier si la valeur change par rapport à la précédente
If currentValue <> previousValue Then
' Ajouter une bordure en bas de la ligne précédente
cell.Offset(-1).Resize(, .Columns.Count).Borders(xlEdgeBottom).LineStyle = xlContinuous
cell.Offset(-1).Resize(, .Columns.Count).Borders(xlEdgeBottom).Weight = xlThin
End If
' Mettre à jour la valeur précédente
previousValue = currentValue
Next
End With
End If
End With
End With
' Nettoyage mémoire
Set Al = Nothing
MsgBox "Données rassemblées avec succès !", vbInformation
End Subklin89
Pour le fun
Option Explicit
Sub Pivot()
Dim a, b, e, pos, index
Dim i As Long, n As Long
Dim Al As Object, dicoFeuilles As Object
Dim tbl(), ws As Worksheet, feuilles
Dim cell As Range, currentValue As String, previousValue As String
Dim wsPivot As Worksheet
' Désactiver les mises à jour pour accélérer l'exécution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Initialisation de l'ArrayList et du Dictionnaire
Set Al = CreateObject("System.Collections.ArrayList")
Set dicoFeuilles = CreateObject("Scripting.Dictionary")
' Récupération des noms de feuilles à parcourir
b = Sheets("Ref échantillons").Range("A1").CurrentRegion.Value
feuilles = Application.index(b, 3, Evaluate("ROW(2:" & UBound(b, 2) & ")"))
' Stocker les feuilles dans un dictionnaire pour éviter les erreurs
For Each e In feuilles
dicoFeuilles(e) = True
Next
' Remplissage de l'ArrayList avec les valeurs uniques de la colonne 1 des feuilles
For Each e In dicoFeuilles.Keys
If SheetExists(CStr(e)) Then
Set ws = Sheets(e)
a = ws.Range("A1").CurrentRegion.Value
For i = 2 To UBound(a, 1) ' On parcourt la 1ère colonne (sans l'en-tête)
If Not Al.Contains(a(i, 1)) Then Al.Add a(i, 1)
Next
End If
Next
' Suppression des valeurs spécifiques
Al.Remove "Unclassified": Al.Remove "Not Analysed"
Al.Sort ' Tri de l'ArrayList
' Initialisation du tableau tbl avec les en-têtes
ReDim tbl(1 To 5, 1 To 1)
tbl(1, 1) = "Ref GeMMe": tbl(2, 1) = "Flux": tbl(3, 1) = "Nom échantillon"
tbl(4, 1) = "Minéraux": tbl(5, 1) = "Concentration"
n = 2 ' Ligne de départ dans tbl
For Each e In dicoFeuilles.Keys
If SheetExists(CStr(e)) Then
Set ws = Sheets(e)
a = ws.Range("A1").CurrentRegion.Value
pos = Application.Match(e, Application.index(b, 3, 0), 0)
' Ajustement dynamique de la deuxième dimension
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) + Al.Count)
' Remplissage des colonnes
For i = 0 To Al.Count - 1
tbl(1, n + i) = e ' Nom de la feuille
tbl(2, n + i) = b(1, pos) ' Flux
tbl(3, n + i) = b(2, pos) ' Nom échantillon
tbl(4, n + i) = Al(i) ' Valeurs de l'ArrayList
' Recherche et correspondance avec `a`
index = Application.Match(Al(i), Application.index(a, 0, 1), 0)
If Not IsError(index) Then
tbl(5, n + i) = a(index, 4) ' Valeurs correspondantes
End If
Next
n = n + Al.Count
End If
Next
' Création ou récupération de la feuille "Pivot_Mineraux"
If Not SheetExists("Pivot_Mineraux") Then
Set wsPivot = Sheets.Add(After:=Sheets(Sheets.Count))
wsPivot.Name = "Pivot_Mineraux"
Else
Set wsPivot = Sheets("Pivot_Mineraux")
End If
' Mise en forme des résultats
With wsPivot
.Cells.ClearContents ' Nettoie uniquement les valeurs
If n > 0 Then
.Cells(1, 1).Resize(UBound(tbl, 2), UBound(tbl, 1)).Value = Application.Transpose(tbl)
With .Cells(1, 1).CurrentRegion
.Font.Name = "Calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.Columns(5).NumberFormat = "0.00"
' Mise en forme de l'en-tête
With .Rows(1)
.HorizontalAlignment = xlCenter
.Font.Size = 11
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 44
End With
.Columns.AutoFit
' Ajout des bordures dynamiques par changement de valeur
previousValue = .Cells(2, 1).Value
For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1)
currentValue = cell.Value
If currentValue <> previousValue Then
cell.Offset(-1).Resize(, .Columns.Count).Borders(xlEdgeBottom).LineStyle = xlContinuous
cell.Offset(-1).Resize(, .Columns.Count).Borders(xlEdgeBottom).Weight = xlThin
End If
previousValue = currentValue
Next
End With
End If
End With
' Réactiver le recalcul et l'affichage
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Nettoyage mémoire
Set Al = Nothing
Set dicoFeuilles = Nothing
MsgBox "Données rassemblées avec succès !", vbInformation
End Sub
' Fonction pour vérifier si une feuille existe
Function SheetExists(sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(sheetName)
SheetExists = Not ws Is Nothing
On Error GoTo 0
End Functionklin89
Bonjour Klin89
Merci pour le code, il fonctionne très bien. C'est vraiment très gentil à vous deux d'avoir proposé ces deux solutions. j'apprécie énormément. Et comme je vous l'ai dit, ça me fait gagner un temps énorme.
Merciiiiiiiiiiiiiiiiiiiiiiiiiiii
Hassan
Bonjour les PROs
Je reviens avec ma dernière demande. Toutes les explications sont données dans les feuilles colorées en vert et il s'agit du même travail que les deux fichier précédents que vous m'aviez aidé à faire. Cette fois ci, il y a un calcul à faire sur la feuille compilation. J'espère que j'étais claire dans mon fichier joint.
Merci infiniment pour votre précieuse aide.
Salutations
Hassan
Bonjour à vous,
J'espère que tout roule et pour tout le monde.
Une cordiale relance par rapport à mon dernier post avec le fichier attaché "Libération-Compilation" si vous avez encore le gout de m'aider. si c'est beaucoup de travail pour vous, je comprendrai vraiment.
Salutations
Hassan
Bonjour senlis01
Voici un premier jet.
Pour l'instant, on ne crée que la feuille "Compilation". Cliquez sur la forme de la feuille "Menu".
Pouvez vous me dire si cela vous convient, s'il y a des erreurs et lesquelles le cas échéant ?
Si des évolutions pour cette feuille sont souhaitées, me le demander.
Bon, on va s'attaquer aux autres feuilles.
Nota : j'ai arrondi les valeurs à deux chiffres après la virgule. Peut-être ne fallait-il pas le faire ?
Re,
La suite avec en plus la feuille ""Liberation Cumulée"".
Bonjour Mafraise,
Je viens de voir vos deux postes, et les deux feuilles fonctionnent comme il se doit. Un énorme Merci. J'ai regardé le code, je n'y comprends absolument rien mais ça donne mal à la tête avec toutes ses lignes
Vraiment Merci infiniment.
Hassan
Re,
Tant mieux si ça fonctionne
Voici la version suivante avec en plus la feuille "Percentiles Pivot";
Même questions que précédemment
Bon, il m'en reste une à faire aujourd'hui...
Re,
Voici la dernière version qui crée les quatre feuilles désirées.
Il faut bien entendu tout vérifier et m'avertir s'il y a des erreurs.
Même sans erreur, ne pas crier victoire !
Ce n'est qu'après avoir testé dans plusieurs situations réelles qu'on pourra considérer que c'est probablement bon. Sinon on remettra l'ouvrage sur le métier.
Coooooool, le job est fait, Merciiiiiiiiiiii, c'est vraiment très très apprécié cher Mafraise
Demain, je vais avoir le plaisir de tester le code avec un fichier déjà fait à la main et je vous tiendrais au courant. J'ai hâte.
Très bonne soirée à vous et je vous tiendrais au courant dès que j'aurais testé le code.
Très belle soirée à vous
Hassan
Bonjour Mafraise, et Klin89
J'ai enfin utilisé et vérifié le dernier code fait par Mafraise, et ça fonctionne très bien sur 34 feuilles Excel. Les 3 codes VBA que vous m'aviez faits pour les trois types de données que je génère fonctionnent très bien et me font gagner un temps FOU. Merci énormément pour votre aide.
Très très cordialement.
Hassan