Compilation des données de plusieurs feuilles vers une seule
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.
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
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
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
Re
Là, je ne m'y frotte pas. Ca sent l'usine à gaz
Cordialement
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
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
Bonjour à tous, Salut Klin
@ Klin
Content de te croiser
M'en vais m'pencher sur le "System.Collections.ArrayList" dont le ".sort" semble prometteur....
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
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
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
Merci Infiniment Kiln, ça marche bien avec la modification que tu suggère. C'est super génial
Mission accomplie