Forum OpenOffice LibreOffice NeoOffice

Bonjour

Extreme néophyte en macro libre office, je voudrais automatiser un process qui me prend pas mal de temps et j’aurais vraiment besoin de compétences….

Alors voilà, j’ai dans un fichier calc, qui peut faire plusieurs dizaines de lignes , des données que je voudrais regrouper dans des classeurs (ou à la limite feuilles) distinct(e)s en fonction d’un critère qui peut éventuellement changer en fonction des besoins : en d’autres termes, parfois le critère sera en colonne B, parfois en D, etc.

Ce que je voudrais donc :
1/ dans un premier temps, sélectionner via une msgbox la cellule (1ere ligne de colonne) contenant le critère en fonction duquel les classeurs seront créés : l’idée est que chaque classeur créé regroupe les données de la feuille qui répondent au même critère
Accessoirement,si c’est possible, mettre une option de contrôle permettant de s’assurer que le critère de création n’est pas farfelu (cellule vide, cellule de la 2eme ligne au lieu de la 1ere, etc...)
2/ créer les classeurs (par hypothèse dans le même emplacement que le fichier d’origine)
3/ si possible, les nommer selon la norme suivante : nom du fichier d’origine - item de la clé de tri retenue

Il me semble que cela pourrait passer par les sous étapes suivantes (en tout cas c’est ± le process de la macro que j’avais avant sous excel… : si ca peut servir, j’ai gardé le code):

a) pour chaque item de la clé de tri
. filtrer la feuille d’origine en fonction de l’item
. copier la sélection
. créer un classeur nommé (nom du fichier d’origine - item de la clé de tri retenue)
. nommer la 1er feuille de la même manière
. coller la sélection dans la feuille du classeur créé
. enregistrer le nouveau classeur ainsi créé

b) réinitialiser les filtres du classeur d’origine

b) passer au second item de la clé de tri et recommencer jusqu’au dernier item

Pour mémoire, j’ai tenté avec l’enregistreur de macros mais c’est lourd, long inélégant et…. peu satisfaisant.

Voilà, je sais que c’est compliqué ….mais si quelqu’un veut faire une BA pour tout ou partie du besoin, un grand merci d’avance !

A toutes fins utiles, je joins un exemple du classeur « de base » qui nécessite d’être exploité.

Cette section a des règles très précises que vous devez obligatoirement suivre pour obtenir de l'aide. C'est indiqué dans le cadre rouge en haut de la page.

Il est demandé aux auteurs de faire précéder le titre de leur question d'une balise adéquate. Ce balisage est extrêmement important car il permet d'avoir une base de connaissance optimum en cas de recherche. Avez-vous remarqué comment étaient les autres questions postées ?

Lisez ce fil pour savoir quelle balise utiliser : http://forum.openoffice.org/fr/forum/su ... html#27295

Nous l'avons fait pour vous cette fois-ci mais lors de votre prochaine question, nous vous remercions de le faire vous-même sous peine de voir votre sujet verrouillé.

Bonjour
Une solution éventuelle à tester. (J'ai du supprimer tous les espaces indésirables dans tes données).

Code : Tout sélectionner

REM  *****  BASIC  *****
Dim oDlg as Object
Global numCol as Long
Dim maFeuille as Object
Dim valFiltre as Variant

Sub Regies
Dim oDoc as Object, NomFeuille() as String, oCol as Variant, i as Integer
	oDoc = thisComponent
	maFeuille = oDoc.CurrentController.ActiveSheet
	DialogLibraries.LoadLibrary("Standard")
	oDlg = CreateUnoDialog(DialogLibraries.Standard.Dialog1)
	oCol = Array("A","B","C","D","E","F","G","H")
	oDlg.getControl("lstCol").Model.StringItemList = oCol()
	oDlg.Execute
End Sub

Sub lesFiltres(oEv as Object)
Dim maZone as Object
Dim CellVide as Variant, y as Long, i as Integer
	NumCol = oEv.Source.SelectedItemPos
	maZone = maFeuille.getCellRangeByPosition(NumCol,1,numCol,500)
	CellVide = maZone.queryEmptyCells.RangeAddresses
	y = cellVide(UBound(cellVide)).StartRow -1
	For i = 1 To y
		redim Preserve tabFiltre(i - 1)
		tabFiltre(i - 1 ) = maFeuille.getCellByPosition(NumCol,i).String
	Next i
	tabFiltre = SortedList(tabFiltre,True)
	For i = LBound(tabFiltre) To UBound(tabFiltre)
		AppliquerFiltre(tabFiltre(i))
	Next i
	oDlg.EndExecute
End Sub

Sub AppliquerFiltre(oFiltre as Variant)
Dim oFilterDesc, FeuilleCopy as Object, maCellule as Object
Dim oFields(0) As New com.sun.star.sheet.TableFilterField
	oFilterDesc = maFeuille.createFilterDescriptor(True)
	With oFields(0)
		.Field = NumCol
		valFiltre = oFiltre
		If isnumeric(oFiltre) Then
			.IsNumeric = True
			.NumericValue = oFiltre
		Else
			.IsNumeric = False
			.StringValue = oFiltre
		End If
		.Operator = com.sun.star.sheet.FilterOperator.EQUAL
	End With
	With oFilterDesc
		.setFilterFields(oFields())
		.ContainsHeader = True
		.CopyOutputData = True
		FeuilleCopy = thisComponent.Sheets.getByName("Copy")
		maCellule = FeuilleCopy.getCellRangeByName("A1")
		.OutputPosition = maCellule.CellAddress
	End With	
	maFeuille.filter(oFilterDesc)
	ThisComponent.Store(True)
	CopySheet
End Sub
'https://forum.openoffice.org/fr/forum/viewtopic.php?f=8&t=57665&p=311473&hilit=copier+feuille#p311473 par Hubert Lambert
Sub CopySheet()
Dim Chemin as Variant, destDoc as Object, destSheet as Object
Dim SourceURL as String
Dim Arg(0) As New com.sun.star.beans.PropertyValue
Dim gomme as Long
	Chemin = Split(ThisComponent.URL,"/")
	Chemin(UBound(Chemin)) = ""
	Chemin = Join(Chemin,"/")
	Arg(0).Name = "Hidden"
	Arg(0).Value = True	
	destDoc = StarDesktop.LoadComponentFromURL("private:factory/scalc", "_default", 0, Arg())
	destSheet = destDoc.Sheets(0)
	If InStr(valFiltre," ") > 0 Then
		valFiltre = Join(Split(valFiltre," "),"_")
	End If	
	If InStr(valFiltre,"/") > 0 Then
		valFiltre = Join(Split(valFiltre,"/"),"_")
	End If
	destSheet.setName(valFiltre)
    sourceURL = convertToURL(Chemin & Split(thisComponent.Title,".")(0) & "_" & valFiltre & ".ods")
    destSheet.link(thisComponent.URL, "Copy", "", "", com.sun.star.sheet.SheetLinkMode.NORMAL)
    destSheet.LinkMode = com.sun.star.sheet.SheetLinkMode.NONE
    destSheet.LinkURL = ""
    destDoc.storeToURL(sourceURL,Array())
    destDoc.Close(True)
    gomme = com.sun.star.sheet.CellFlags.HARDATTR + _
	com.sun.star.sheet.CellFlags.STRING + _
	com.sun.star.sheet.CellFlags.VALUE
	thisComponent.sheets.getByName("Copy").clearContents(gomme)
End Sub

'https://forum.openoffice.org/fr/forum/viewtopic.php?f=8&t=42864&p=234425&hilit=trier+un+tableau#p234416 par alhazred
    'Tri rapide : séparer en deux, trier les parties, les imbriquer
    'noDouble = true pour supprimer les doublons
    'les indices commencent à 0
Function SortedList(list, noDouble As Boolean)
Dim ub%
	ub = UBound(list)
	If ub<1 Then
		SortedList = list
		Exit Function
	End If
             
Dim ub1%, list1, list2
       
       'Diviser la liste en deux
	ub1 = ub\2
	list1 = ListSegment(list,0,ub1)
	list2 = ListSegment(list,ub1+1,ub)
       
       'Trier les parties
	list1 = SortedList(list1,noDouble)
	list2 = SortedList(list2,noDouble)
       
       'Les imbriquer
	SortedList = SortedUnion(list1,list2,noDouble)
End Function

    '************************************************************************
    'Former une nouvelle liste en prenant à chaque fois le plus petit élément.
Function SortedUnion(list1, list2, noDouble As Boolean)
Dim i1%, ub1%, elem1, i2%, ub2%, elem2, i%, ub%, elem
	ub1 = Ubound(list1)
	ub2 = UBound(list2)
	ub = ub1+ub2+1
Dim list(0 To ub)
       
       'i1 = 0 : i2 = 0 : i = 0 'inutile
	While i1<=ub1 And i2<=ub2
		elem1 = list1(i1)
		elem2 = list2(i2)
		If noDouble And elem1=elem2 Then
			list(i) = elem1
			i1 = i1+1
			i2 = i2+1
		ElseIf elem2<elem1 Then '<--- ici pour changer le mode de tri
			list(i) = elem2
			i2 = i2+1
		Else
			list(i) = elem1
			i1 = i1+1
		End If
			i = i+1
	Wend
       
       'Une des listes est épuisée : compléter avec les éléments restants de l'autre liste
	If i2<=ub2 Then
		For i2=i2 To ub2
			list(i) = list2(i2)
			i = i+1
		Next i2
	Else
		For i1 =i1 To ub1
			list(i) = list1(i1)
			i = i+1
		Next i1
	End If
       
       'Redimensionner si des doublons ont été éliminés
	If i<=ub Then Redim Preserve list(0 To i-1)
       
	SortedUnion = list
End Function

    '**********************************************************
    'Retourne la liste des éléments pour les indices de lb à ub
    'org (0 par défaut) est la base de la nouvelle liste
Function ListSegment(list, lb%, ub%, Optional org%)
	If IsMissing(org) Then org=0
       'décalage des indices
Dim delta% : delta = lb-org
       
Dim list1(org To ub-delta), i%
	For i = lb To ub
		list1(i-delta) = list(i)
	Next i
	ListSegment = list1
End Function

A+

Forum OpenOffice LibreOffice NeoOffice

[Calc] Création de multiples ODS à partir de filtres

[Calc] Création de multiples ODS à partir de filtres

Re: Création de classeurs multiples à partir de filtres d'un

Re: [Calc] Création de multiples ODS à partir de filtres