Option Explicit
Sub Creation_des_paniers()
Dim myAreas As Areas, w(), n As Long, y, x As Long, w2 As Long
Dim i As Long, j As Long, k As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'On crée une copie de la feuille source
'sur laquelle on va travailler : version sans formule
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Copie").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets("récap commandes").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Copie"
Sheets("Copie").Move before:=Sheets("récap commandes")
'Nettoyage de la copie pour y voir plus clair et réorganisation des données
With Sheets("copie")
With .UsedRange
.Value = .Value
.Font.ColorIndex = 1
.Interior.ColorIndex = -4142
.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
On Error Resume Next
.Columns("A").SpecialCells(2, 1).EntireRow.Delete
.Columns("A").SpecialCells(4).EntireRow.Delete
On Error GoTo 0
.Columns(1).Insert
With .Range("b1", .Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=if(or(b1= ""Total"",b1= ""RETOUR LISTE NOMS""),1,"""")"
.Value = .Value
On Error Resume Next
.SpecialCells(2, 1).Offset(1).EntireRow.Insert shift:=xlShiftUp
On Error GoTo 0
End With
.Columns(1).Delete
On Error Resume Next
Set myAreas = .Columns("A").SpecialCells(2).Areas
On Error GoTo 0
End With
'Traitement des données
If Not myAreas Is Nothing Then
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To myAreas.Count
If myAreas(i).Rows.Count > 3 Then
For j = 5 To myAreas(i).CurrentRegion.Columns.Count
If Application.CountA(myAreas(i).Columns(j)) > 3 Then
If Not .exists(myAreas(i)(1, j).Value) Then
ReDim w(1 To 4, 1 To Application.CountA(myAreas(i).Columns(j)) - 2)
w(1, 1) = " Produits "
w(2, 1) = "Panier de " & myAreas(i)(1, j).Value
w(3, 1) = "Quantité"
w(4, 1) = "Montant"
For k = 3 To myAreas(i).Rows.Count - 1
If myAreas(i)(k, j).Value <> "" Then
n = n + 1
w(1, n + 1) = myAreas(i)(1, 1).Value
w(2, n + 1) = myAreas(i)(k, 1).Value
w(3, n + 1) = myAreas(i)(k, j).Value
w(4, n + 1) = myAreas(i)(k, j).Value * myAreas(i)(k, 3).Value
End If
If n + 1 = Application.CountA(myAreas(i).Columns(j)) - 2 Then Exit For
Next
.Item(myAreas(i)(1, j).Value) = w
n = 0
Else
w = .Item(myAreas(i)(1, j).Value)
w2 = UBound(w, 2)
ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + Application.CountA(myAreas(i).Columns(j)) - 3)
For k = 3 To myAreas(i).Rows.Count - 1
If myAreas(i)(k, j).Value <> "" Then
n = n + 1
w(1, w2 + n) = myAreas(i)(1, 1).Value
w(2, w2 + n) = myAreas(i)(k, 1).Value
w(3, w2 + n) = myAreas(i)(k, j).Value
w(4, w2 + n) = myAreas(i)(k, j).Value * myAreas(i)(k, 3).Value
End If
If n = Application.CountA(myAreas(i).Columns(j)) - 3 Then Exit For
Next
.Item(myAreas(i)(1, j).Value) = w
n = 0
w2 = 0
End If
End If
Next
End If
Next
x = .Count: y = .items
End With
'restitution et mise en forme
'recopie à droite dans la feuille "paniers"
If x > 0 Then
With Sheets("paniers")
.Cells.Clear
For i = 0 To UBound(y)
With .Cells(1, n + 1)
.Resize(UBound(y(i), 2), UBound(y(i), 1)).Value = Application.Transpose(y(i))
With .CurrentRegion
With .Offset(.Rows.Count).Resize(1)
.Value = _
Array("Total", "Panier", "-", "=sum(r2c:r[-1]c)")
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.Interior.ColorIndex = 38
.BorderAround Weight:=xlThin
End With
With .Rows(.Rows.Count)
.Interior.ColorIndex = 43
.BorderAround Weight:=xlThin
End With
With .Columns(.Columns.Count)
.NumberFormat = "# ##0.00 €"
.HorizontalAlignment = xlRight
End With
.Columns.AutoFit
End With
End With
End With
End With
n = n + UBound(y(i)) + 1
Next
.Columns.AutoFit
.Activate
End With
Else
MsgBox "Pas de paniers en commande"
End If
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
