[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.

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

Messagepar CoachFab » 09 Mars 2013 21:03

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   AgrandirRéduire
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é 1365 fois
Dernière édition par CoachFab le 12 Mars 2013 15:47, édité 1 fois.
LibreOffice 4.1.2.3 (Xubuntu 13.10 et Opensuse 12.3)
CoachFab
Membre lOOyal
Membre lOOyal
 
Message(s) : 32
Inscrit le : 23 Mars 2010 16:11

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

Messagepar Dude » 08 Juin 2017 15:18

Le code mentionné plus haut est incomplet et ne peut fonctionner.
Il manque des fonctions :
Code : Tout sélectionner   AgrandirRéduire
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
Dude
Grand Maître de l'OOffice
Grand Maître de l'OOffice
 
Message(s) : 19561
Inscrit le : 03 Mars 2006 09:45
Localisation : 127.0.0.1

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

Messagepar ThierryT » 08 Juin 2017 20:36

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 5.4.3.1 x64 (20/10/2017) / AOO 4.1.3 (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
Avatar de l’utilisateur
ThierryT
Membre enthOOusiaste
Membre enthOOusiaste
 
Message(s) : 456
Inscrit le : 10 Nov 2012 19:05


Retour vers Suprême de code

Qui est en ligne ?

Utilisateur(s) parcourant ce forum : Aucun utilisateur inscrit et 1 invité