Sub DémoPilot()
Dim i As Long, x As Long, y As Long, z As Long, t As Long, derlig As Long, dercol As Long, num As Long
Dim IndicePrec As Long, lin As Long, j As Byte
Dim Copi(), tableur()
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Application.ScreenUpdating = False
With k1
For lin = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1 'boucle inverse sur feuille k1 pr suppression des lignes vides
If .Rows(lin).Find("*") Is Nothing Then .Rows(lin).Delete 'si absence de valeur dans la ligne alors on la supprime
Next lin
z = Application.Match("Date émission", .Rows(1), 0) 'permet de retrouver n°colonne Date émission en ligne 1, sécurise ainsi le filtre
y = Application.Match("raison sociale titulaire", .Rows(1), 0) 'permet de retrouver n°colonne raison sociale en ligne 1, sécurise ainsi le filtre
derlig = .Range(.Cells(1, y), .Cells(65536, y)).End(xlDown).Row + 1 'definit la dernière ligne non vide de la colonne qui fait apparaitre raison sociale titulaire
dercol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne non vide sur ligne 1
.Range(.Cells(1, 1), .Cells(derlig, dercol)).Sort key1:=.Cells(1, y), order1:=xlAscending, key2:=.Cells(1, z), order2:=xlAscending, Header:=xlYes 'tri sur 2 critères (raison social et date)en ordre croissant
tableur = .Range(.Cells(2, 1), .Cells(derlig, dercol)) 'enregistrement de la BD en tableau VBA (ligne 2 car les 1ère données se trouvent en général sur celle-ci !)
End With
IndicePrec = 0
For i = 1 To UBound(tableur, 1) - 1 'du début de ligne du tableau a la dernière valeur - 1 (dimension 1)
If tableur(i, y) <> tableur(i + 1, y) Then 'si la raison sociale change alors
num = i 'num égal le dernier indice du tableau vba
ReDim Copi(1 To num - IndicePrec, 1 To dercol) 'création d'un tableau variable propre à chaque plage de données
For t = IndicePrec + 1 To num 'du début de chaque plage(n°ligne) à la fin(n°ligne)
x = x + 1 ' Indice du tableau copi
For j = 1 To dercol
Copi(x, j) = tableur(t, j) 'Copi integrera en valeur 1 les premières données de chaque plage
Next j
Next t
'****** copie dans nouveau classeur ************
Set xlBook = Workbooks.Add 'ouvrir un nouvel excel
'xlApp.Visible = False 'le rendre invisible
With xlBook.Worksheets("Feuil2")
.Range("A2").Resize(UBound(Copi, 1), UBound(Copi, 2)) = Copi
End With
xlBook.SaveAs ThisWorkbook.Path & "\" & Copi(1, 4) & ".xls"
xlBook.Close
Set xlBook = Nothing
'********* fin copie ***************************
x = 0 'RAZ indice Copi
IndicePrec = i ' mémorisation de la dernière ligne de la plage qui deviendra premiere ligne de plage suivante
End If
Next i
Application.ScreenUpdating = True
End Sub