Fusionner cellules identiques
paritec a écrit :Bonjour Eddyeddy patrick le forum
Voilà avec les deux dernières colonnes
a+
Papou
Bonjour Papou,
Merci pour cette nouvelle version.
Je regarderai çela à tête reposée car pas le temps ce jour !
Joyeux Noël et au plaisir.
Eddy
paritec a écrit :Bonjour Eddyeddy patrick le forum
Voilà avec les deux dernières colonnes
a+
Papou
Bonjour Papou, bonjour Patrick, bonjour le forum,
Super impeccable Papou cette nouvelle version.
L'onglet "Menu" est ce que je souhaitait.
Seul petit bémol, les données fusionnées des colonnes f et g ne sont pas l'une en dessous de l'autre !
Sinon, grand merci car c'est vraiment super et
Ré bonjour Edyeddy le forum
En fait tu ne sais pas vraiment ce que tu veux!!!
Tu veux fusionner je suppose pour raccourcir le fichier mais tu veux les informations les unes en dessous des autres???
Ce qui aura pour conséquence de conserver le même nombre de lignes!!!!!
C'est cela que tu veux??
Si oui aucun problème pour moi je le ferai
A plus
Papou
paritec a écrit :En fait tu ne sais pas vraiment ce que tu veux!!!
Je pense aussi ou alors des explications incomplètes
P.
Bonsoir Patrick
oui c'est pas que l'on comprend rien, mais il veut fusionner et en même temps, il veut conserver le même nombre de ligne???
Ou alors sa seule inquiétude était simplement de faire les totaux des colonnes prix total et nombre de pièces?
mais bon peut-être va t'il nous expliquer cela en détails !!!!
on peut lui faire ce qu'il veut encore faut-il comprendre ce qu'il veut.
bonne soirée et bon Week-end
Papou
Bonsoir à tous,
Concaténer dans une seule cellule, tu vas vite atteindre les limites de ton écran
Test sur une seule feuille.
Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long
a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1: .Item(a(i, 1)) = n
For j = 1 To UBound(a, 2)
a(n, j) = a(i, j)
Next
Else
a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) + a(i, 3)
a(.Item(a(i, 1)), 5) = a(.Item(a(i, 1)), 5) + a(i, 5)
a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & vbLf & a(i, 6)
a(.Item(a(i, 1)), 7) = a(.Item(a(i, 1)), 7) & vbLf & a(i, 7)
End If
Next
End With
Application.ScreenUpdating = False
With Sheets.Add().Cells(1).Resize(n, UBound(a, 2))
.Value = a
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.VerticalAlignment = xlTop
With .Rows(1)
.Interior.ColorIndex = 6
.BorderAround Weight:=xlThin
.VerticalAlignment = xlCenter
End With
.Columns.AutoFit
.Rows.AutoFit
End With
Application.ScreenUpdating = True
End Sub
klin89
paritec a écrit :Ré bonjour Edyeddy le forum
En fait tu ne sais pas vraiment ce que tu veux!!!
Tu veux fusionner je suppose pour raccourcir le fichier mais tu veux les informations les unes en dessous des autres???
Ce qui aura pour conséquence de conserver le même nombre de lignes!!!!!
C'est cela que tu veux??
Si oui aucun problème pour moi je le ferai
A plus
Papou
Bonsoir Papou, Bonsoir Patrick,
Ce n'est pas le fait que je ne sais pas ce que je veux car dans un précédent message j'avais insérer une image de ce que j'aimerai obtenir ! Voir lien https://forum.excel-pratique.com/download/file.php?id=110427&mode=view
En tout cas, merci beaucoup pour le travail.
Eddy
Klin89 a écrit :Bonsoir à tous,
Concaténer dans une seule cellule, tu vas vite atteindre les limites de ton écran
Test sur une seule feuille.
Option Explicit Sub test() Dim a, i As Long, j As Long, n As Long a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value n = 1 With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 2 To UBound(a, 1) If Not .exists(a(i, 1)) Then n = n + 1: .Item(a(i, 1)) = n For j = 1 To UBound(a, 2) a(n, j) = a(i, j) Next Else a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) + a(i, 3) a(.Item(a(i, 1)), 5) = a(.Item(a(i, 1)), 5) + a(i, 5) a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & vbLf & a(i, 6) a(.Item(a(i, 1)), 7) = a(.Item(a(i, 1)), 7) & vbLf & a(i, 7) End If Next End With Application.ScreenUpdating = False With Sheets.Add().Cells(1).Resize(n, UBound(a, 2)) .Value = a .Borders(xlInsideVertical).Weight = xlThin .BorderAround Weight:=xlThin .VerticalAlignment = xlTop With .Rows(1) .Interior.ColorIndex = 6 .BorderAround Weight:=xlThin .VerticalAlignment = xlCenter End With .Columns.AutoFit .Rows.AutoFit End With Application.ScreenUpdating = True End Sub
klin89
Bonsoir klin89,
Merci d'apporter ton aide sur à ma demande mais que dois je faire avec le code ci-dessus ?
Eddy
Re EddyEddy,
Dans ton cas, la concaténation de tes données dans les cellules des colonnes F et G n'est pas une bonne idée.
Tu vas vite atteindre les limites de tes cellules et tronquer leur contenu.
Perso, je verrai la disposition sur plusieurs lignes.
Sinon, faut-il parcourir plusieurs feuilles ?
A tester :
Option Explicit
Sub test()
Dim a, i As Long, w(), n As Long, x As Long, y
a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
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 1)
w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3)
w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6)
w(7, 1) = a(i, 7)
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
x = UBound(w, 2)
w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5))
w(6, x) = a(i, 6): w(7, x) = a(i, 7)
.Item(a(i, 1)) = w
End If
Next
y = .items
End With
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Restitution").Delete
On Error GoTo 0
Application.DisplayAlerts = True
With Sheets.Add().Cells(1)
.Parent.Name = "Restitution"
With .Resize(, UBound(a, 2))
'.EntireColumn.Clear
.Value = a
End With
With .Offset(1)
For i = 0 To UBound(y)
With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
.Value = Application.Transpose(y(i))
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
n = n + UBound(y(i), 2)
Next
End With
With .CurrentRegion
.Font.Size = 10
.VerticalAlignment = xlCenter
.Rows.RowHeight = 16
With .Rows(1)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 6
.HorizontalAlignment = xlCenter
.RowHeight = 27
End With
.Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €")
.Columns.AutoFit
End With
End With
Application.ScreenUpdating = True
End Sub
Edit : bonjour paritec, patrick1957
klin89
Klin89 a écrit :Re EddyEddy,
Dans ton cas, la concaténation de tes données dans les cellules des colonnes F et G n'est pas une bonne idée.
Tu vas vite atteindre les limites de tes cellules et tronquer leur contenu.
Perso, je verrai la disposition sur plusieurs lignes.
Sinon, faut-il parcourir plusieurs feuilles ?
A tester :
Option Explicit Sub test() Dim a, i As Long, w(), n As Long, x As Long, y a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value 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 1) w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3) w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6) w(7, 1) = a(i, 7) .Item(a(i, 1)) = w Else w = .Item(a(i, 1)) ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1) x = UBound(w, 2) w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5)) w(6, x) = a(i, 6): w(7, x) = a(i, 7) .Item(a(i, 1)) = w End If Next y = .items End With Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False Sheets("Restitution").Delete On Error GoTo 0 Application.DisplayAlerts = True With Sheets.Add().Cells(1) .Parent.Name = "Restitution" With .Resize(, UBound(a, 2)) '.EntireColumn.Clear .Value = a End With With .Offset(1) For i = 0 To UBound(y) With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1)) .Value = Application.Transpose(y(i)) .BorderAround Weight:=xlThin .Borders(xlInsideVertical).Weight = xlThin End With n = n + UBound(y(i), 2) Next End With With .CurrentRegion .Font.Size = 10 .VerticalAlignment = xlCenter .Rows.RowHeight = 16 With .Rows(1) .BorderAround Weight:=xlThin .Borders(xlInsideVertical).Weight = xlThin .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .RowHeight = 27 End With .Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €") .Columns.AutoFit End With End With Application.ScreenUpdating = True End Sub
Edit : bonjour paritec, patrick1957
klin89
Bonjour klin89
Que veux tu dire par "faut-il parcourir plusieurs feuilles" ?
Et le code ci-dessus, à quoi sert-il ?
Merci, Eddy
Re Bonsoir à Tous le forum
Voilà Eddyeddy le résultat comme tu le souhaites
a+
Papou
Re EddyEddy,
Evite de rééditer mes codes, cela encombre le fil 8)
La même solution que Paritec, sauf que je ne fusionne pas les cellules des colonnes F et G
Soit une feuille distincte créée pour chaque feuille traitée.
Option Explicit
Sub test()
Dim a, i As Long, w(), n As Long, x As Long, s, y, sn As String
Application.ScreenUpdating = False
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
'On parcourt les feuilles à traiter (à compléter)
For Each s In Array("Liste Art 2009", "Liste Art 2010")
a = Sheets(s).Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
ReDim w(1 To 7, 1 To 1)
w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3)
w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6)
w(7, 1) = a(i, 7)
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
x = UBound(w, 2)
w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5))
w(6, x) = a(i, 6): w(7, x) = a(i, 7)
.Item(a(i, 1)) = w
End If
Next
y = .items
On Error Resume Next
Application.DisplayAlerts = False
sn = Right(s, 8)
Sheets(sn).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On crée une feuille distincte pour chaque feuille traitée
Sheets.Add().Name = sn
With Sheets(sn).Cells(1)
n = 0
With .Resize(, UBound(a, 2))
.Value = a
End With
With .Offset(1)
For i = 0 To UBound(y)
With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
.Value = Application.Transpose(y(i))
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
n = n + UBound(y(i), 2)
Next
End With
With .CurrentRegion
.Font.Size = 10
.VerticalAlignment = xlCenter
.Rows.RowHeight = 16
With .Rows(1)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 6
.HorizontalAlignment = xlCenter
.RowHeight = 27
End With
.Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €")
.Columns.AutoFit
End With
End With
.RemoveAll
Next
End With
Application.ScreenUpdating = True
End Sub
Nouvelle question : faut-il traiter toutes les feuilles et résumer le tout sur une seule feuille ?
klin89
paritec a écrit :Re Bonsoir à Tous le forum
Voilà Eddyeddy le résultat comme tu le souhaites
a+
Papou
Bonsoir Papou,
Mes meilleurs vœux pour cette nouvelle année.
L'exemple N°4 est comme je l'espérai et grand merci.
@+
Eddy
Bonsoir Patrick et klin89,
Mes meilleurs vœux pour cette nouvelle année à vous aussi.
Merci de m'avoir également apporter votre aide sur ce sujet.
La dernière proposition de Papou (paritec) me convenait parfaitement car c'est ce que je désirai.
@+
Eddy