Salut Max_MM,
à tester
Sub RegrouperFacturations()
Dim shs As Worksheet, shd As Worksheet
Dim RemplirPlage As Variant
Dim Xshs, Yshs, Yshd As Long
Set shs = Worksheets("Base de données contrats")
' créer une nouvelle feuille "Resultat"
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Resultat"
End With
Set shd = Worksheets("Resultat")
' insérer les titres dans la feuille Resultat
RemplirPlage = VBA.Array("Nombre unique", "facturations", "Commision par facturation")
shd.Range("A1:C1").Value = RemplirPlage
Yshd = 2
With shs
For Xshs = 15 To 34
For Yshs = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row
If .Cells(Yshs, Xshs) <> "" Then
shd.Cells(Yshd, 1) = .Cells(Yshs, 1) ' recupérer le numéro unique
shd.Cells(Yshd, 2) = .Cells(Yshs, Xshs) ' recupérer la date de facturation
shd.Cells(Yshd, 2).NumberFormat = "m/d/yyyy" ' formater la céllule
shd.Cells(Yshd, 3) = .Cells(Yshs, 14) ' recupérer la Commision par facturation
Yshd = Yshd + 1
End If
Next Yshs
Next Xshs
shd.Columns("A:C").AutoFit
End With
End Sub
Pour trier les données, il faut ajouter ce code avant le "End Sub"
Derligne = shd.Cells(shd.Rows.Count, "A").End(xlUp).Row
With shd.Sort
.SortFields.Add Key:=Range("A2:A" & Derligne), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:C" & Derligne)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Bonne nuit