Macro découpage tableau en plusieurs fichiers format LibreOffice

Bonjour,

Vous trouverez ci-joint un fichier Excel avec plusieurs onglets.
Je souhaite créer une macro pour découper le premier onglet en plusieurs autres fichiers au format Libreoffice (FileFormat:=xlOpenDocumentSpreadsheet).

La macro devrait pouvoir découper le premier onglet en fonction des données remplies colonne B (à partir de la cellule B15 jusqu’à la fin du tableau qui peut potentiellement aller jusqu’en bas de la feuille).
Dans l’exemple, il y a 6 types de données dans la cellule B. La macro devrait donc créer 6 fichiers différents (cf. les autres onglets pour l’exemple).

Attention cependant, le nombre de lignes de chacun de ces données peut évoluer et ces données pourraient ne pas être égales en nombre.
Par exemple, il pourrait y avoir beaucoup plus de lignes avec la donnée 001 que de lignes avec la donnée 005. Le nombre de lignes du tableau peut aussi être beaucoup plus grand que ce qui est donné dans l’exemple.

En vous remerciant par avance pour vos propositions, je vous souhaite une bonne journée.

Bien à vous,

Sinokisme

Bonjour Sinokisme

Est-ce que ce tutoriel répondrait à ton besoin? https://www.exceldemy.com/split-excel-sheet-into-multiple-sheets-based-on-column-value/

Le format LibreOffice ne serait t'il pas un problème secondaire?

Bonjour Scraper,

Je te remercie pour ta réponse. Effectivement le format est une problématique secondaire.
La macro VBA dans la page que tu m'as linké fonctionne très bien.
Je remets le code ici :

Sub Splitsheet()
Dim lr As Long
Dim sheet As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Select the header row:", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox _
("Select the column on the basis of which split data:", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set sheet = xTRg.Worksheet
lr = sheet.Cells(sheet.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = sheet.Columns.Count
sheet.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
sheet.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If sheet.Cells(i, vcol) <> "" And Application.WorksheetFunction. _
Match(ws.Cells(i, vcol), sheet.Columns(icol), 0) = 0 Then
sheet.Cells(sheet.Rows.Count, icol).End(xlUp).Offset(1) = sheet.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(sheet.Columns(icol). _
SpecialCells(xlCellTypeConstants))
sheet.Columns(icol).Clear
For i = 2 To UBound(myarr)
sheet.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
sheet.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr) _
.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
sheet.AutoFilterMode = False
sheet.Activate
Application.DisplayAlerts = True
End Sub

Est-ce que tu saurais modifier ce code pour que la macro crée un nouveau fichier LibreOffice (FileFormat:=xlOpenDocumentSpreadsheet) au lieu d'une nouvelle feuille à chaque fois ?
Je te remercie par avance pour ton expertise et te souhaite une agréable journée.

Bien à toi,

Sinokisme

Bonjour Sinokisme.

Je n'ai pas testé le code que je t'ai conseillé mais s'il fonctionne je n'y toucherai pas. Attention adapter les exceptions

Sub copysheetsExceptXY()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
if ws.name <> "x" and ws.name <> "y" Then
ActiveSheet.Copy
wb_name = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:= Environ("USERPROFILE") & wb_name & ".xlsx", FileFormat:=60
ActiveWorkbook.Close
End if
Next ws

End Sub

Merci Scraper.
J'ai l'impression que ton code permet de créer des fichiers une fois que les onglets ont été composés avec la première macro.
Or les fichiers sont créés ouverts et il faut les enregistrer, ce qui demande beaucoup de manipulation s'il y a 100 onglets.

N'existerait-il pas une macro qui permet de créer directement des fichiers séparés sur le répertoire à la racine de l'emplacement où se situe le fichier contenant la macro ?

D'avance merci.

Rebonjour Scraper,

J'ai trouvé la macro que je cherchais à cette adresse : https://www.extendoffice.com/documents/excel/628-excel-split-workbook.html

Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Il faut d'abord appliquer la première macro pour découper le fichier en onglet puis la deuxième pour créer des fichiers séparés sur le répertoire.
Par contre je ne sais comment ni où insérer la commande FileFormat:=xlOpenDocumentSpreadsheet pour obtenir des fichiers .ods

Si tu as une idée, je suis preneur^^

Bonne journée

Sinokisme

Au lieu de :

Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"

il faut :

Const xlOpenDocumentSpreadsheet=60

Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".ods", FileFormat:=xlOpenDocumentSpreadsheet

Bonjour Scraper,

Excuse-moi pour l'absence de réponse. J'ai malheureusement eu de gros contretemps ses derniers temps.
Je te remercie beaucoup pour ta réponse et pour tes éclaircissements. Je vais essayer ta proposition.
Je te souhaite une bonne journée :)

Sinokisme

Rebonjour Scraper,

Ta macro pour splitter en .ods fonctionne très bien.
Par contre, j'ai réessayé la macro pour découper un fichier de 38 000 lignes en plusieurs onglets (celle à cette adresse : https://www.exceldemy.com/split-excel-sheet-into-multiple-sheets-based-on-column-value/) et cela ne fonctionne pas.

Est-ce qu'il existerait une macro qui pourrait découper une feuille en plusieurs onglets peu importe le nombre de lignes ?

Je ne peux pas mettre de fichier en copie pour l'exemple car il fait plus de 1,5 Mo.
Le forum Excel-pratique ne permet pas d'ajouter les fichiers compressés de type 7Z.

Sinon, je peux aussi réouvrir un thread pour trouver une solution à cette problématique.

Bien à toi,
Sinokisme