[Calc] Cellules : formater, écrire, lire, trier, copier, etc

Vos meilleures macros et portions de code sont publiées dans cette section.
Aucun support sur une question de programmation ici !

Modérateur : Vilains modOOs

Règles du forum
Aucune question dans cette section !
Celle-ci rassemble les meilleures macros et portions de code. Vous pouvez en revanche commenter ou argumenter le code exposé. Vous pouvez même remercier l'auteur (cela fait toujours plaisir) en indiquant par exemple dans quel cadre ou contexte vous en avez eu l'utilité.
Si vous avez à poster quelque chose, faites-le depuis la section Macros et API et demandez à un modérateur de l'y déplacer.
CoachFab
Membre lOOyal
Membre lOOyal
Messages : 32
Inscription : 23 mars 2010 15:11

[Calc] Cellules : formater, écrire, lire, trier, copier, etc

Message par CoachFab »

Bonjour,

Cela fait un moment que je n'étais passé sur le forum mais j'en profite pour mettre à disposition des fonctions "génériques" que j'utilise dans l'outil que j'ai crée pour gérer les compétences du socle commun.
Vous trouverez donc des fonctions pour la gestions des cellules :
- cellules : pour formater une cellule ou des zones, pour écrire ou lire une cellule, trier, copier, déplacer ...

Si ces fonctions peuvent etre utiles pour certains j'en serai ravi.

Code : Tout sélectionner

REM  *****  BASIC  *****
Option explicit

'-----------------------------------------------------------------------------------------------
'Fonctions pour la gestion des cellules
'-----------------------------------------------------------------------------------------------
'Macro qui enregistre dans une cellule la valeur chaine dans la feuille donnée
'-----------------------------------------------------------------------------------------------
Sub EnrCell(feuille as String, Chaine as String, col as Integer, lig as Integer, Optional doc as Object)
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	Sheet.getCellByPosition(col,lig).String=Chaine
end Sub
'-----------------------------------------------------------------------------------------------
'Enregistre une valeur dans une cellule
'-----------------------------------------------------------------------------------------------
Sub EnrCellValue(feuille as String, Chaine as Double, col as Integer, lig as Integer, Optional doc as Object)
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	Sheet.getCellByPosition(col,lig).Value=Chaine
end Sub
'-----------------------------------------------------------------------------------------------
'Enregistre une formule dans une cellule
'-----------------------------------------------------------------------------------------------
Sub EnrCellFormula(feuille as String, formula as String, col as integer, lig as Integer, Optional doc as Object)
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	Sheet.getCellByPosition(col,lig).Formula="="& formula
end Sub
'-----------------------------------------------------------------------------------------------
'Enregistre une formule sans sign"="
'-----------------------------------------------------------------------------------------------
Sub EnrCellFormulaDate(feuille as String, formula as String, col as integer, lig as Integer, Optional doc as Object)
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	Sheet.getCellByPosition(col,lig).FormulaLocal=formula
end Sub
'-----------------------------------------------------------------------------------------------
'macro qui renvoie le string d'une cellule
'-----------------------------------------------------------------------------------------------
Sub CellString(feuille as string, col as Integer, lig as Integer, Optional doc as Object) as String
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	CellString=Sheet.getCellByPosition(col,lig).String
end Sub
'-----------------------------------------------------------------------------------------------
'macro qui renvoie le value d'une cellule
'-----------------------------------------------------------------------------------------------
Sub CellValue(feuille as string, col as Integer, lig as Integer, Optional doc as Object) as double
Dim Sheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	if not VerifFeuille(feuille,oDoc) then 
		Exit Sub
	end if
	Sheet=RetourneFeuille(feuille,oDoc)
	CellValue=Sheet.getCellByPosition(col,lig).Value
end Sub
'-----------------------------------------------------------------------------------------------


'-----------------------------------------------------------------------------------------------
'Macros pour gérer la mise forme d'une cellule
'-----------------------------------------------------------------------------------------------
Sub HCenter(feuille as String, c As Integer, l as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).HORIJUSTIFY=com.sun.star.table.CellHoriJustify.CENTER
end Sub
'-----------------------------------------------------------------------------------------------
Sub VCenter(feuille as String, c As Integer, l as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).VERTJUSTIFY=com.sun.star.table.CellVertJustify.CENTER
end Sub
'-----------------------------------------------------------------------------------------------
Sub Gras(feuille as String, c As Integer, l as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).CharWeight=com.sun.star.awt.FontWeight.BOLD
end Sub
'-----------------------------------------------------------------------------------------------
Sub Wrapped(feuille as String, c As Integer, l as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).IsTextWrapped=true
end Sub
'-----------------------------------------------------------------------------------------------
Sub BottomTop(feuille as String, c As Integer, l as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).Orientation=com.sun.star.table.CellOrientation.BOTTOMTOP
end Sub
'-----------------------------------------------------------------------------------------------
Sub BackColor(feuille as String, c As Integer, l as Integer, R as Integer, G as Integer, B as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).CellBackColor=RGB(R,G,B)
end Sub
'-----------------------------------------------------------------------------------------------
Sub CharColor(feuille as String, c As Integer, l as Integer, R as Integer, G as Integer, B as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).CharColor=RGB(R,G,B)
end Sub
'-----------------------------------------------------------------------------------------------
Sub CharHeight(feuille as String, c As Integer, l as Integer, taille as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).Charheight=taille
end Sub
'-----------------------------------------------------------------------------------------------
Sub MargesInternes(feuille as String, c as integer, l as Integer, retrait as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellByPosition(c,l).ParaIndent=retrait
end Sub
'-----------------------------------------------------------------------------------------------
Sub LargOptimale(feuille as String, col as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).Columns(col).OptimalWidth=true
end sub
'-----------------------------------------------------------------------------------------------
Sub HautOptimale(feuille as String, lig as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).Rows(lig).OptimalHeight=true
end sub
'-----------------------------------------------------------------------------------------------
Sub LigneHeight(feuille as String, lig as Integer, hauteur as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).Rows(lig).Height=hauteur
end sub
'-----------------------------------------------------------------------------------------------
Sub ColWidth(feuille as String, col as Integer, larg as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).Columns(col).Width=larg
end sub
'-----------------------------------------------------------------------------------------------


'-----------------------------------------------------------------------------------------------
'Macros pour gérer la mise forme d'une zone de cellules
'-----------------------------------------------------------------------------------------------
Sub ZoneHautOptimale(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object, oSheet as object, lignes as object, zone as object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	oSheet=RetourneFeuille(feuille,oDoc)
	zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
	lignes=zone.Rows
	lignes.OptimalHeight=true
end sub
'-----------------------------------------------------------------------------------------------
Sub ZoneLargOptimale(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object, oSheet as object, lignes as object, zone as object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	oSheet=RetourneFeuille(feuille,oDoc)
	zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
	lignes=zone.Columns
	lignes.OptimalWidth=true
end sub
'-----------------------------------------------------------------------------------------------
Sub BorduresZone(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object)
Dim zone as Object, oSheet as Object, bords as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
oSheet=RetourneFeuille(feuille,oDoc)
zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
bords=zone.TableBorder
Dim unBord as New com.sun.star.table.BorderLine
With unBord
	.OuterLineWidth=30
	.Color=RGB(0,0,0)
	bords.RightLine=unBord
	bords.LeftLine=unBord
	bords.TopLine=unBord
	bords.BottomLine=unBord
	bords.VerticalLine=unBord
	bords.HorizontalLine=unBord
end with
With Bords
	.IsBottomLineValid=true
	.IsTopLineValid=true
	.IsLeftLineValid=true
	.IsRightLineValid=true
	.IsHorizontalLineValid=true
	.IsVerticalLineValid=true
end with
zone.TableBorder=bords
end sub
'-----------------------------------------------------------------------------------------------
Sub ZoneBackColor(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, R as Integer, G as Integer, B as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).CellBackColor=RGB(R,G,B)
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneCharHeight(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, taille as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).CharHeight=taille
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneCharColor(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, R as Integer, G as Integer, B as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).CharColor=RGB(R,G,B)
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneHCenter(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).HORIJUSTIFY=com.sun.star.table.CellHoriJustify.CENTER
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneVCenter(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).VERTJUSTIFY=com.sun.star.table.CellVertJustify.CENTER
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneWrapped(feuille as String, colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if	
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).IsTextWrapped=true
end Sub
'-----------------------------------------------------------------------------------------------
Sub ZoneBottomTop(feuille as String,  colI As Integer, ligI as Integer, colF As Integer, ligF as Integer, Optional doc as Object)
Dim oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	RetourneFeuille(feuille,oDoc).getCellRangeByPosition(colI,ligI,colF,ligF).Orientation=com.sun.star.table.CellOrientation.BOTTOMTOP
end Sub
'-----------------------------------------------------------------------------------------------


'-----------------------------------------------------------------------------------------------
'Fonctions sur la gestion des zones
'-----------------------------------------------------------------------------------------------
'Retourne l'index de ligne de fin d'une zone
'-----------------------------------------------------------------------------------------------
Function IndexFinZone(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object) as Integer
Dim Index as Integer, Sheet as Object, zone as Object, ZonesVides as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
Sheet=RetourneFeuille(feuille,oDoc)
zone=Sheet.getCellRangeByPosition(colI,ligI,colF,ligF)
ZonesVides=zone.queryEmptyCells.RangeAddresses
if UBound(ZonesVides) >= 0 then
	index=ZonesVides(0).StartRow
end if
IndexFinZone=index-1
end Function
'-----------------------------------------------------------------------------------------------
'fusionne une zone de cellules
'-----------------------------------------------------------------------------------------------
Sub Fusionne(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer,Optional doc as Object)
Dim Sheet as Object, zone as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
Sheet=RetourneFeuille(feuille,oDoc)
zone=Sheet.getCellRangeByPosition(colI,ligI,colF,ligF)
zone.merge(true)
end Sub
'-----------------------------------------------------------------------------------------------
'Fonction qui convertit une zone de cellules en tableau
'-----------------------------------------------------------------------------------------------
Function ZoneVersTab(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object) as Variant
Dim oSheet as Object, zone as Object, tab as Variant, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	oSheet=RetourneFeuille(feuille,oDoc)
	zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
	ZoneVersTab=zone.DataArray
end Function
'-----------------------------------------------------------------------------------------------
'Ecrit les valeurs d'un array dans une zone
'-----------------------------------------------------------------------------------------------
Sub TabVersZone(feuille as String, tab as Variant, colI as integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object) 
Dim oSheet as Object, zone as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	oSheet=RetourneFeuille(feuille,oDoc)
	zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
	zone.DataArray=tab
end Sub
'-----------------------------------------------------------------------------------------------
'Ecrit les valeurs d'un array avec des formules dans une zone
'-----------------------------------------------------------------------------------------------
Sub TabFormulesVersZone(feuille as String, tab as Variant, colI as integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object) 
Dim oSheet as Object, zone as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	oSheet=RetourneFeuille(feuille,oDoc)
	zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
	zone.FormulaArray=tab
end Sub
'-----------------------------------------------------------------------------------------------
'Macro qui filtre une zone suivant le critère donné (on recopie dans le meme doc)
'-----------------------------------------------------------------------------------------------
Sub FiltrerZone(feuilleini as String, zone as String, crit as Variant, col as integer, feuille as String, cellule as String, num as boolean, Optional doc as Object)
'zone doit etre donné sous la forme a1:b2, col correspond au numero de colonne à filtrer dans la zone
Dim monDocument As Object, lesFeuilles As Object 
Dim maFeuille As Object, maZone As Object, index as Integer
Dim monFiltre As Object, feuilleResu As Object, pointResu As Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if

Dim champsFiltre(0) As New com.sun.star.sheet.TableFilterField
if num=true then 
	With champsFiltre(0)
	  .Field = col
	  .Operator = com.sun.star.sheet.FilterOperator.EQUAL
	  .IsNumeric = true
	  .NumericValue = crit
	End With
else 
	With champsFiltre(0)
	  .Field = col
	  .Operator = com.sun.star.sheet.FilterOperator.EQUAL
	  .IsNumeric = False
	  .StringValue = crit
	End With
end if
maFeuille = RetourneFeuille(feuilleini, oDoc)
maZone = maFeuille.getCellRangeByName(zone)
monFiltre = maZone.createFilterDescriptor(True)
With monFiltre
  .CopyOutputData = True 
  .ContainsHeader = False
  .Orientation = com.sun.star.table.TableOrientation.COLUMNS
  feuilleResu = RetourneFeuille(feuille,oDoc)
  .OutputPosition = feuilleResu.getCellRangeByName(cellule).CellAddress
  .FilterFields = champsFiltre()
End With
maZone.filter(monFiltre)
End Sub
'-----------------------------------------------------------------------------------------------
'copie une zone de cellule dans la feuille farriv à partir de la cellule en col et lig (meme doc)
'-----------------------------------------------------------------------------------------------
Sub CopierZone(zone as Object, farriv as String, col as Integer, lig as Integer, Optional doc as Object )
Dim cell as Object, SheetArriv as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
	SheetArriv=RetourneFeuille(farriv,oDoc)
	cell=SheetArriv.getCellByPosition(col,lig)
	SheetArriv.copyRange(cell.CellAddress,zone.RangeAddress)
end Sub
'-----------------------------------------------------------------------------------------------
'Retourne le nom d'une colonne d'index donné
'-----------------------------------------------------------------------------------------------
Function NomColonne(X as Long) as String
Dim uneCellule as Object
	uneCellule=ThisComponent.Sheets(0).getCellByPosition(X,0)
	NomColonne=uneCellule.Columns.ElementNames(0)
end Function
'-----------------------------------------------------------------------------------------------
'Retourne l'index d'une colonne de nom donné
'-----------------------------------------------------------------------------------------------
Function IndexColonne(nom as String) as Long
Dim uneCellule as Object
	uneCellule=ThisComponent.Sheets(0).getCellRangeByName(nom &"1")
	IndexColonne=uneCellule.RangeAddress.StartColumn
end Function
'-----------------------------------------------------------------------------------------------
'Efface tous les elements d'une zone
'-----------------------------------------------------------------------------------------------
Sub EffaceZone(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, Optional doc as Object)
Dim zone as Object, oSheet as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
oSheet=RetourneFeuille(feuille,oDoc)
zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
zone.clearContents(com.sun.star.sheet.CellFlags.VALUE +_
com.sun.star.sheet.CellFlags.DATETIME +com.sun.star.sheet.CellFlags.STRING +_
com.sun.star.sheet.CellFlags.HARDATTR +com.sun.star.sheet.CellFlags.FORMULA)
end sub
'-----------------------------------------------------------------------------------------------
'Déplace tous les elements d'une zone
'-----------------------------------------------------------------------------------------------
Sub DeplaceZone(feuille as String, farriv as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, col as Integer, lig as Integer, Optional doc as Object)
Dim oSheet as Object, zone as Object, oSheetArriv as Object, cArriv as Object, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
oSheet=RetourneFeuille(feuille,oDoc)
oSheetArriv=RetourneFeuille(farriv,oDoc)
zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
cArriv=oSheetArriv.getCellByPosition(col,lig)
oSheetArriv.moveRange(cArriv.CellAddress,zone.RangeAddress)
end sub
'-----------------------------------------------------------------------------------------------
'Macro pour le tri d'une zone sur une colonne
'-----------------------------------------------------------------------------------------------
Sub Trier1Colonne(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, col as Integer,Optional tri as boolean, Optional doc as Object)
Dim maFeuille As Object, maZone As Object, typetri as boolean
Dim ConfigTri(0) As New com.sun.star.table.TableSortField
Dim DescrTri As Variant, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
If IsMissing(tri) then
	typetri=true
else
	typetri=tri
end if
maFeuille = RetourneFeuille(feuille,oDoc)
maZone=maFeuille.getCellRangeByPosition(colI,ligI,colF,ligF)

With ConfigTri(0)
  .Field = col ' le numero de colonne
  .IsAscending = typetri
End With

DescrTri = maZone.createSortDescriptor
setPropVal(DescrTri, "SortFields", ConfigTri())
setPropVal(DescrTri, "IsSortColumns", false)
setPropVal(DescrTri, "CopyOutputData", false) 
setPropVal(DescrTri, "IsUserListEnabled", false) 
setPropVal(DescrTri, "BindFormatsToContent", false) 
setPropVal(DescrTri, "ContainsHeader", false)
maZone.Sort(DescrTri()) 
End Sub
'-----------------------------------------------------------------------------------------------
'Supprime les lignes : le nb de lignes nb à partir de la ligne rang
'-----------------------------------------------------------------------------------------------
Sub SupprLignes(feuille as string,colI as Integer, ligI as Integer, colF as Integer, ligF as Integer,rang as integer, nb as integer)
Dim lignes as object, zone as object, oSheet as object
oSheet=RetourneFeuille(feuille)
zone=oSheet.getCellRangeByPosition(colI,ligI,colF,ligF)
lignes=zone.Rows
lignes.removeByIndex(rang,nb)
end sub
'-----------------------------------------------------------------------------------------------
'Macro pour le tri d'une zone sur deux colonne
'zone est sous la forme "A1:B5"
'-----------------------------------------------------------------------------------------------
Sub Trier2Colonne(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, col1 as Integer,col2 as Integer,Optional doc as Object)
Dim maFeuille As Object, maZone As Object
Dim ConfigTri(1) As New com.sun.star.table.TableSortField
Dim DescrTri As Variant, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
maFeuille = RetourneFeuille(feuille,oDoc)
maZone=maFeuille.getCellRangeByPosition(colI,ligI,colF,ligF)
ConfigTri(0).Field = col1 ' le numero de colonne
ConfigTri(0).IsAscending = true
ConfigTri(1).Field = col2 ' le numero de colonne
ConfigTri(1).IsAscending = true
DescrTri = maZone.createSortDescriptor
setPropVal(DescrTri, "SortFields", ConfigTri())
setPropVal(DescrTri, "IsSortColumns", false)
setPropVal(DescrTri, "CopyOutputData", false) 
setPropVal(DescrTri, "IsUserListEnabled", false) 
setPropVal(DescrTri, "BindFormatsToContent", false) 
setPropVal(DescrTri, "ContainsHeader", false)
maZone.Sort(DescrTri()) 
End Sub
'-----------------------------------------------------------------------------------------------
'Macro pour le tri d'une zone sur trois colonnes
'zone est sous la forme "A1:B5"
'-----------------------------------------------------------------------------------------------
Sub Trier3Colonne(feuille as String, colI as Integer, ligI as Integer, colF as Integer, ligF as Integer, col1 as Integer,col2 as Integer,col2 as Integer, Optional doc as Object)
Dim maFeuille As Object, maZone As Object
Dim ConfigTri(2) As New com.sun.star.table.TableSortField
Dim DescrTri As Variant, oDoc as Object
If IsMissing(doc) then
	oDoc=ThisComponent
else
	oDoc=doc
end if
maFeuille = RetourneFeuille(feuille,oDoc)
maZone=maFeuille.getCellRangeByPosition(colI,ligI,colF,ligF)
ConfigTri(0).Field = col1 ' le numero de colonne
ConfigTri(0).IsAscending = true
ConfigTri(1).Field = col2 ' le numero de colonne
ConfigTri(1).IsAscending = true
ConfigTri(2).Field = col3 ' le numero de colonne
ConfigTri(2).IsAscending = true
DescrTri = maZone.createSortDescriptor
setPropVal(DescrTri, "SortFields", ConfigTri())
setPropVal(DescrTri, "IsSortColumns", false)
setPropVal(DescrTri, "CopyOutputData", false) 
setPropVal(DescrTri, "IsUserListEnabled", false) 
setPropVal(DescrTri, "BindFormatsToContent", false) 
setPropVal(DescrTri, "ContainsHeader", false)
maZone.Sort(DescrTri()) 
End Sub

Fabien
macros-cellules-feuilles.ods
Macros pour cellules et feuilles
(13.52 Kio) Téléchargé 2296 fois
Dernière modification par CoachFab le 12 mars 2013 14:47, modifié 1 fois.
LibreOffice 4.1.2.3 (Xubuntu 13.10 et Opensuse 12.3)
Avatar de l’utilisateur
Dude
IdOOle de la suite
IdOOle de la suite
Messages : 25124
Inscription : 03 mars 2006 08:45
Localisation : 127.0.0.1
Contact :

Re: [Calc] Cellules : formater, écrire, lire, trier, copier,

Message par Dude »

Le code mentionné plus haut est incomplet et ne peut fonctionner.
Il manque des fonctions :

Code : Tout sélectionner

Function VerifFeuille( sFeuille, oDoc) As boolean
	Dim bExiste as boolean, oFeuille as object, oListe as object
	bExiste = false
	oListe = ListeFeuilles(oDoc)
	Do while oListe.hasMoreElements
	   oFeuille = oListe.nextElement
	   if oFeuille.name = sFeuille then
	      bExiste = true
	      exit do
	   endif
	Loop
	VerifFeuille = bExiste
End function
Function RetourneFeuille( sFeuille, oDoc) As object
	Dim oFeuille as object, oListe as object
	oListe = ListeFeuilles(oDoc)
	Do while oListe.hasMoreElements
	   oFeuille = oListe.nextElement
	   if oFeuille.name = sFeuille then
	   	  RetourneFeuille = oFeuille	
	      exit do
	   endif
	Loop
End function
Function ListeFeuilles( oDoc ) as variant
	Dim oFeuilles as object
	oFeuilles = oDoc.Sheets 
	ListeFeuilles = oFeuilles.createEnumeration
End Function
Etonnant que personne n'en ait fait la remarque depuis 2013 :shock:
Avatar de l’utilisateur
ThierryT
Membre enthOOusiaste
Membre enthOOusiaste
Messages : 467
Inscription : 10 nov. 2012 18:05

Re: [Calc] Cellules : formater, écrire, lire, trier, copier,

Message par ThierryT »

Bonsoir,

Les fonctions VerifFeuille et RetourneFeuille sont bien présentes dans le fichier (Module Feuilles).
Capture.PNG
Par contre, je ne vois pas où est utilisé la fonction ListeFeuilles dans les modules du fichier ?
LibreOffice 6.1.3.2 x64 / AOO 4.1.5 (x86) sous Windows 8.1 (x64)
Java 8.x (x64 et x86), Firefox, Thunderbird,....

“Celui qui aime à apprendre est bien près du savoir.” (Confusius)
Comment baliser Résolu
Répondre