Sub eclater_jaba()
Dim nwbk As Workbook
Dim dl&, dc%, i&, iDeb&, iFn&
Dim ws As Worksheet, r As Range, iCl%
On Error Resume Next
With ActiveSheet
Set r = .Range([A2], .[A65536].End(xlUp))
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCl = r.Column
Application.ScreenUpdating = False
dl = .Cells(Rows.Count, "A").End(xlUp).Row
dc = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(dl, dc)).Sort Key1:=.Cells(2, iCl), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iDeb = 2
For i = 2 To dl
If .Cells(i, iCl).Value <> .Cells(i + 1, iCl).Value Then
iFn = i
Workbooks.Add xlWBATWorksheet
Set nwbk = ActiveWorkbook
Set ws = nwbk.Sheets(1)
On Error Resume Next
ws.Name = .Cells(iDeb, iCl).Text
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, dc)).Value = .Range(.Cells(1, 1), .Cells(1, dc)).Value
.Range(.Cells(iDeb, 1), .Cells(iFn, dc)).Copy ws.Range("A2")
nwbk.SaveAs "C:\Temp\" & ws.Name
nwbk.Close True
iDeb = iFn + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sinon pourquoi ai-je recu un MP de ta part relatif à ce fil ci ?Dites vous bien que le but de ce forum est un partage de connaissance sur le Net. Les participants souhaitent ne pas avoir leur messagerie inondée de vos problèmes personnels. Si vous avez un fichier que vous désirez soumettre, faites toujours une demande préalable. Les
questions doivent rester dans le Forum .
jaba à dit:Bonjour Staple 1600,
est il possible de faire en sorte que la macro que tu m'as envoyée éclate un tableau en plusieurs fichiers excel en fonction d'une critère en faisant un copié en valeur du tableau, et garde la couleur de la première ligne?
Merci d'avance.
.Range(.Cells(1, 1), .Cells(1, dc)).Copy
ws.[A1].PasteSpecial xlValues
ws.[A1].PasteSpecial xlFormats
.Range(.Cells(iDeb, 1), .Cells(iFn, dc)).Copy ws.Range("A2")