EXCEL :: Les Tableaux Structurés :: Une classe VBA - V1.05 - Evolutions majeures exports CSV, XML, XML UTF-8, JSON, HTML, PDF, JPG, JPEG, BMP, EXCEL

oguruma · 2 Mai 2025

Bonjour Le Forum,
ce post fait suite aux discussions
Discuss 1
Discuss 2

Dans le code je n'ai pas été le seul 😉 pour certains exports. Voir les discussions 😉 🙂
Il apporte les exports aux formats

Je vous laisse tester ces boutons et consulter le code que je place ci-dessous

VB:

Option Explicit

'****************************************************************************************************
'*  Classe CLS_TS sur les tableaux structurés
'****************************************************************************************************
'* Auteur    : OGURUMA
'* Date      : 21/04/2025
'* Version   : Initiale
'* V1.01     : 22/04/2025
'* V1.02     : 26/04/2025 - Ajout des exports xml, csv, json
'* V1.03     : 01/05/2025 - Ajout des exports xml2 utf-8 et html - P. TOULON (XLD)
'* V1.04     : 01/05/2025 - Ajout de l'export format image - P. TOULON (XLD)
'* V1.05     : 02/05/2025 - Ajout export format PDF et image version 2
'*                        - Ajout création d'un TS à partir d'une plage ou d'une cellule
'*                        - Ajout export d'un TS dans un autre classeur soit en plage soit en TS
'****************************************************************************************************
Const Erreur As String = "<#:: Erreur :: Traitement sur l'objet TS impossible ::#>"

Private Const ERROR_MESSAGE As Long = vbObjectError + 9100
Private Const ERROR_SOURCE As String = "CLS_TS"
Private Const ERROR_MSG As String = ":: ABANDON - 9100 :: Incident de traitement :: "

Private pOTools As CLS_TOOLS_EXISTS

Private pWb_MACRO As Workbook
Private pWk As Worksheet
Private pTable As ListObject
Private pObjectTable As ListObject
Private pIsExistsQueryTable As Boolean
Private pQueryTable As QueryTable

Private pRange As Range
Private pDataBody As Range
Private pHeaders As Range
Private pTblHeaders As Variant

Private pListRows As ListRows
Private pListColumns As ListColumns
Private pRow As ListRow
Private pColumn As ListColumn

Private pNameTS As String
Private pNbRows As Long
Private pTableNbRows As Long
Private pNbColumns As Integer
Private pAddressData As String
'---------
' V1.01
'---------
Private pWkName As String
Private pDataRow As Long
Private pDataColumn As Integer
Private pHeaderAddress As String
Private pHeaderRow As Long
Private pHeaderColumn As Integer
'---------
' V1.02
'---------
Private pQueryTableCommandText As String
Private pQueryTableConnection As String
Private pQueryTableBackGroundQuery As Boolean
Private pQueryTableWorkbookConnection As WorkbookConnection
Private pQueryTableWorkbookConnectName As String
Private pQueryTableWorkbookConnectDescr As String
Private pQueryTableLocation As String


Private Sub Class_Initialize()
'*************************************************************************************
'* Iniatlisation de la classe et des objets principaux
'*************************************************************************************
    Set pWb_MACRO = ThisWorkbook
    Set pOTools = New CLS_TOOLS_EXISTS
End Sub

Sub Instantiate(hTB As String, Optional hWk As String = "§_§ACTIVESHEET§_§")

' Instanciation nécessaire afin de capter les éléments du tableau à traiter
'--------------------------------------------------------------------------

    Dim wk As Worksheet
    If hWk = "§_§ACTIVESHEET§_§" Then
        Set wk = ActiveSheet
    Else
        If Not pOTools.wkExist(pWb_MACRO, hWk) Then
            Err.Raise _
                ERROR_MESSAGE, _
                ERROR_SOURCE, _
                ERROR_MSG & " : La feuille " & hWk & " est inconnue"
        Else
            Set wk = pWb_MACRO.Worksheets(hWk)
        End If
    End If
  
    ' On va vérifier sa présence pour ne pas planter
    '------------------------------------------------
    If Not pOTools.exitsTS(hTB) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le tableau " & hTB & " est inconnu"
    End If
  
    ' Initialisation des différentes propriétés
    '-------------------------------------------
    Set pRange = Range(hTB & "[#All]") ' V1.05 ça manquait, prévu mais non initialisé
    Set pTable = wk.ListObjects(hTB)
    Set pDataBody = pTable.DataBodyRange
    Set pObjectTable = Range(hTB).ListObject
    Set pWk = wk
    pWkName = wk.Name
    pNameTS = pTable.Name
    pNbRows = pDataBody.Rows.Count
    pDataRow = pDataBody.row
    pDataColumn = pDataBody.Column
    pHeaderAddress = pTable.HeaderRowRange.Address
    pHeaderRow = pTable.HeaderRowRange.row
    pHeaderColumn = pTable.HeaderRowRange.Column
    pNbColumns = pDataBody.Columns.Count
    pAddressData = pDataBody.Address
    Set pHeaders = Range(hTB & "[#Headers]") ' les titres des colonnes
    pTblHeaders = pHeaders.Cells
  
    ' Si le TS existe on va récupérer les infos nécessaires
    pIsExistsQueryTable = pOTools.IsExistsQueryTable(wk.Name, hTB)
    If pIsExistsQueryTable Then
        Set pQueryTable = pTable.QueryTable
        pQueryTableCommandText = pQueryTable.CommandText
        pQueryTableConnection = pQueryTable.Connection
        pQueryTableBackGroundQuery = pQueryTable.BackgroundQuery
        Set pQueryTableWorkbookConnection = pQueryTable.WorkbookConnection
        pQueryTableWorkbookConnectName = pQueryTable.WorkbookConnection.Name
        pQueryTableWorkbookConnectDescr = pQueryTable.WorkbookConnection.Description
    Else
        pQueryTableCommandText = "<N/A>"
        pQueryTableConnection = "<N/A>"
        pQueryTableWorkbookConnectName = "<N/A>"
        pQueryTableWorkbookConnectDescr = "<N/A>"
        Set pQueryTable = Nothing
        Set pQueryTableWorkbookConnection = Nothing
    End If
End Sub

Property Get Name() As String
    Name = pNameTS ' Nom du tableau structuré
End Property

Property Get Address() As String
    Address = pAddressData ' La plage d'adresse qu'il occupe
End Property

Property Get Headers() As Variant
    Headers = pTblHeaders ' Ses titres de colonnes
End Property

' Début V1.01
Property Get NameWk() As String
    NameWk = pWkName ' nom de la feuille qui l'héberge
End Property

Property Get HeaderAddress() As String
    HeaderAddress = pHeaderAddress ' Adresse des titres de colonnes
End Property

Property Get HeaderRow() As Long
    HeaderRow = pHeaderRow ' ligne de début du TS
End Property

Property Get HeaderColumn() As Long
    HeaderColumn = pHeaderColumn ' colonne de début du TS
End Property

Property Get DataRow() As Long
    DataRow = pDataRow ' Où commence les données dans le tableau ?
End Property

Property Get DataColumn() As Long
    DataColumn = pDataColumn ' La colonne des données
End Property

' Fin V1.01

' Début V1.02
Property Get table() As ListObject
    Set table = pTable  ' Table en tant qu'objet
End Property

Property Get Data() As Range
    Set Data = pDataBody ' Table des données
End Property

Property Get IsExistsQueryTable() As Boolean
    IsExistsQueryTable = pIsExistsQueryTable  ' le TS a-t-il une connexion powerquery
End Property

Property Get CommandText() As String
    CommandText = pQueryTableCommandText ' Commande de connexion powerquery
End Property

Property Get ConnectionName() As String
    ConnectionName = pQueryTableWorkbookConnectName ' Nom de la connexion powerquery
End Property
 
Property Get QueryTableWorkbookConnectDescr() As String
    QueryTableWorkbookConnectDescr = pQueryTableWorkbookConnectDescr ' Description de la connexion Pwq
End Property

Property Get QueryTB() As QueryTable
    Set QueryTB = pQueryTable ' lien avec powerquery - utilisé pour le refresh de la table via pwq
End Property

Property Get QueryConnection() As WorkbookConnection
   Set QueryConnection = pQueryTableWorkbookConnection ' connexion pwq
End Property

Property Get QueryTableConnection()
    QueryTableConnection = pQueryTableConnection ' lien avec la connexion pwq
End Property

' Fin V1.02

Function getNbrows() As Long
    pNbRows = pDataBody.Rows.Count ' nbr de lignes de données
    getNbrows = pDataBody.Rows.Count
End Function

Function getTableNbrows() As Long
    pTableNbRows = pDataBody.Rows.Count ' nbr de lignes
    getTableNbrows = pTable.ListRows.Count
End Function

Function getNbColumns() As Integer
    pNbColumns = pDataBody.Columns.Count ' nnbr de colonnes
    getNbColumns = pDataBody.Columns.Count
End Function

Function getHeaderToString(Optional hSep = ";") As String
' on récupère les titres de colonnes sous forme de chaine
    Dim iDx As Integer
    Dim sHead As String
    For iDx = LBound(pTblHeaders, 1) To UBound(pTblHeaders, 2)
        sHead = sHead & pTblHeaders(1, iDx) & hSep
    Next
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getHeaderToString = Left(sHead, Len(sHead) - Len(hSep))
End Function

Function getHeaders() As Variant
' on récupère les titres dans un tableau
    Dim iDx As Integer
    Dim sHead As String
    Dim vHeaders As Variant
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    ReDim vHeaders(0)
    For iDx = LBound(pTblHeaders, 1) To UBound(pTblHeaders, 2)
        ReDim Preserve vHeaders(iDx)
        vHeaders(iDx - 1) = pTblHeaders(1, iDx)
    Next
    ReDim Preserve vHeaders(UBound(vHeaders) - 1)
    getHeaders = vHeaders
End Function

Function getDataBodyCount() As Long
' On renvoie le nbr de lignes de données
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyCount = pDataBody.Count
End Function

Function getDataBodyCellsCount() As Long
' variante on renvoie le nbr de cellules de données
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyCellsCount = pDataBody.Cells.Count
End Function

Function getObjectTableCount() As Long
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getObjectTableCount = pObjectTable.Range.Count
End Function

Function getObjectTableColumnItem(hColumn As String, hIndex As Long) As Variant
' tableau d'une colonne par son index dans le databodyrange
    If Not pOTools.existsColumnName(pHeaders, hColumn) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le colonne " & hColumn & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getObjectTableColumnItem = pObjectTable.ListColumns(hColumn).DataBodyRange(hIndex)
End Function

Function getObjectTableColumnIndex(hColumn As String) As Integer
' on renvoie l'index d'une colonne
    If Not pOTools.existsColumnName(pHeaders, hColumn) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getObjectTableColumnIndex = pObjectTable.ListColumns(hColumn).Index
End Function

Function getObjectTableColumnCells(hColumn As String) As Variant
' tableau contenant les valeurs d'une colonnes
    If Not pOTools.existsColumnName(pHeaders, hColumn) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getObjectTableColumnCells = pObjectTable.ListColumns(hColumn).Range.Cells
End Function

Function getDataBodyColumnCells(hIndex As Integer) As Variant
' tableau des données
    If hIndex < 1 Or hIndex > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hIndex & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyColumnCells = pDataBody.Columns(hIndex).Cells
End Function

Function getDataBodyRowCells(hIndex As Integer) As Variant
    If hIndex < 1 Or hIndex > pDataBody.Rows.Count Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hIndex & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyRowCells = pDataBody.Rows(hIndex).Cells
End Function

Function getDataBodyRowCellsValue(hRow As Long, hColumn As Integer) As Variant
    If hRow < 1 Or hRow > pDataBody.Rows.Count Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyRowCellsValue = pDataBody.Cells(hRow, hColumn)
End Function

Function getDataCells() As Variant
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataCells = pDataBody.Cells
End Function

Function getTableCells() As Variant
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getTableCells = pTable.Range.Cells
End Function

Function getTableListRows() As ListRows
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set getTableListRows = pTable.ListRows
End Function

Function getTableListColumns() As ListColumns
    pNbColumns = pDataBody.Columns.Count
    Set getTableListColumns = pTable.ListColumns
End Function

Function getDataSumColumn(hColumn As Integer) As Double
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    getDataSumColumn = Application.WorksheetFunction.Sum(pDataBody.Columns(hColumn))
End Function

Function getDataSumRow(hRow As Long) As Double
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    If hRow < 1 Or hRow > pNbRows Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    getDataSumRow = Application.WorksheetFunction.Sum(pDataBody.Rows(hRow))
End Function

Function isIntoTS() As Boolean
    Dim oTB As ListObject
    Dim rActiveCell As Range
    Set rActiveCell = ActiveCell
    Set oTB = rActiveCell.ListObject
    If oTB Is Nothing Then
        isIntoTS = False
    Else
        isIntoTS = True
    End If
End Function

Function xLookupData(hColumn As Integer, hData As Variant) As Variant
    Dim oTB As ListObject
    Dim vResult As Variant
    Dim rLookup As Range
    Dim iLigTab As Long
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    Set oTB = Range(pNameTS).ListObject
    ReDim vResult(4)
    Set rLookup = pDataBody.Columns(hColumn).Find(hData, lookat:=xlWhole)
    If Not rLookup Is Nothing Then
        vResult(0) = True
        vResult(1) = rLookup.row
        iLigTab = oTB.ListRows(rLookup.row - oTB.HeaderRowRange.row).Index
        vResult(2) = iLigTab
        vResult(3) = "Ligne dans la feuille : " & rLookup.row
        vResult(4) = "Ligne dans le tableau : " & iLigTab
    Else
        vResult(0) = False
    End If
    xLookupData = vResult
End Function

Function xLookupThrowAllData(hData As Variant) As Variant
    Dim oTB As ListObject
    Dim vResult As Variant
    Dim rLookup As Range
    Dim iLigTab As Long
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = Range(pNameTS).ListObject
    ReDim vResult(5)
    Set rLookup = pDataBody.Find(hData, lookat:=xlWhole)
    If Not rLookup Is Nothing Then
        vResult(0) = True
        vResult(1) = rLookup.row
        vResult(2) = rLookup.Column
        iLigTab = oTB.ListRows(rLookup.row - oTB.HeaderRowRange.row).Index
        vResult(3) = iLigTab
        vResult(4) = "Ligne dans la feuille : " & rLookup.row & " colonne : " & rLookup.Column
        vResult(5) = "Ligne dans le tableau : " & iLigTab
    Else
        vResult(0) = False
    End If
    xLookupThrowAllData = vResult
End Function

Function isColumnExists(hColumn As String) As Boolean
    Dim oColumn As ListColumn
    On Error Resume Next
    Set oColumn = pTable.ListColumns(hColumn)
    isColumnExists = False
    If Err.Number = 0 Then
        isColumnExists = True
    End If
    On Error GoTo -1
End Function

Function setColumnsValuesByName(hColumn As String, hValue As Variant) As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    setColumnsValuesByName = False
    If Not pOTools.existsColumnName(pHeaders, hColumn) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    Range(pNameTS & "[" & hColumn & "]") = hValue
    setColumnsValuesByName = True
End Function

Function setColumnsValuesByIndex(hColumn As Integer, hValue As Variant) As Boolean
    Dim rCell As Range
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    setColumnsValuesByIndex = False
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    For Each rCell In pDataBody.Columns(hColumn)
        rCell.Value = hValue
    Next
    setColumnsValuesByIndex = True
End Function

Function setRowsValuesByIndex(hRow As Integer, hValue As Variant, Optional hOffset As Boolean) As Boolean
    Dim rCell As Range
    Dim iDex As Integer
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    setRowsValuesByIndex = False
    If hRow < 1 Or hRow > pNbRows Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    For Each rCell In pDataBody.Rows(hRow).Cells
        iDex = iDex + 1
        If hOffset Then
            If iDex > 1 Then rCell.Value = hValue
        Else
            rCell.Value = hValue
        End If
    Next
    setRowsValuesByIndex = True
End Function

Function setRowsValuesByIndexV2(hRow As Integer, hValue As Variant, Optional hOffset As Integer) As Boolean
    Dim rCell As Range
    Dim iDex As Integer
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    setRowsValuesByIndexV2 = False
    If hRow < 1 Or hRow > pNbRows Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    For Each rCell In pDataBody.Rows(hRow).Cells
        iDex = iDex + 1
        If hOffset > 0 Then
            If iDex >= hOffset Then rCell.Value = hValue
        Else
            rCell.Value = hValue
        End If
    Next
    setRowsValuesByIndexV2 = True
End Function

Function deleteRows(hRow As Integer) As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    deleteRows = False
    If hRow < 1 Or hRow > pNbRows Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    Call pDataBody.Rows(hRow).Delete
    deleteRows = True
End Function

' V1.02
Function clearContentsRow(hRow As Long) As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    clearContentsRow = False
    If hRow < 1 Or hRow > pNbRows Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La ligne " & hRow & " est inconnue"
    End If
    Call pDataBody.Rows(hRow).Clear
    clearContentsRow = True
End Function

' V1.02
Function clearContentsVisibleRow() As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    clearContentsVisibleRow = False
    Call pDataBody.SpecialCells(xlCellTypeVisible).Clear
    clearContentsVisibleRow = True
End Function

' V1.02
Function deleteVisibleRow() As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    deleteVisibleRow = False
    Application.DisplayAlerts = False
    Call pDataBody.SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    deleteVisibleRow = True
End Function

' V1.02
Function clearContentsColumnByIndex(hColumn As Integer) As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    clearContentsColumnByIndex = False
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    Call pDataBody.Columns(hColumn).Clear
    clearContentsColumnByIndex = True
End Function

' V1.02
Function clearContentsColumnByName(hColumn As String) As Boolean
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    clearContentsColumnByName = False
    If Not pOTools.existsColumnName(pHeaders, hColumn) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    'Call pDataBody.Columns(hColumn).Clear
    Range(pNameTS & "[" & hColumn & "]").Clear
    clearContentsColumnByName = True
End Function


Sub DataBodyClearContents()
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    pDataBody.clearcontents
End Sub

Sub setDataFilter(hColumn As Integer, hCriteria As String, Optional hOp As String = "=")
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    If hColumn < 1 Or hColumn > pNbColumns Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : La colonne " & hColumn & " est inconnue"
    End If
    With pDataBody
         .AutoFilter Field:=hColumn, Criteria1:=hOp & hCriteria
    End With
End Sub

Sub activateDataFilter()
    Dim oTB As ListObject
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = Range(pNameTS).ListObject
    On Error Resume Next
    If oTB.AutoFilter Is Nothing Then Range(pNameTS).AutoFilter
    On Error GoTo -1
End Sub

Sub deactivateDataFilter()
    Dim oTB As ListObject
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = Range(pNameTS).ListObject
    On Error Resume Next
    If Not oTB.AutoFilter Is Nothing Then Range(pNameTS).AutoFilter
    On Error GoTo -1
End Sub

Sub showAllDataFilter()
    Dim oTB As ListObject
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = pWk.ListObjects(pNameTS)
    If oTB.ShowAutoFilter Then oTB.AutoFilter.ShowAllData
End Sub

Sub hideRowTotal()
    Dim oTB As ListObject
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = Range(pNameTS).ListObject
    On Error Resume Next
    oTB.TotalsRowRange.Delete
End Sub

Sub showRowTotal()
    Dim oTB As ListObject
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    Set oTB = Range(pNameTS).ListObject
    On Error Resume Next
    oTB.ShowTotals = True
End Sub

Sub eraseTable()
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
      With pDataBody
        If .Rows.Count > 1 Then
          .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
      End With
      pDataBody.Rows(1).clearcontents
End Sub

Sub resizeTS(hAddress As String)
' V1.01
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    pTable.Resize Range(hAddress)
End Sub

Sub exportToCSV(hFileName As String, Optional hSep As String = ";", Optional hReplace As Integer = True)
    Dim iFp As Integer
    Dim sColumnsHeader As String
    Dim sRecord As String
    Dim iLig As Long
    Dim iCol As Integer
    Dim iNbrLig As Long
    Dim iNbrCol As Integer
    Dim vColumnValues As Variant
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
  
    Close
    iFp = FreeFile
   ' sColumnsHeader = getHeaderToString()
   ' Print #iFp, sColumnsHeader
    Open hFileName For Output As iFp
    vColumnValues = getTableCells
    sRecord = ""
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    iNbrLig = pDataBody.Rows.Count + 1
    iNbrCol = pDataBody.Columns.Count
    For iLig = 1 To iNbrLig
        sRecord = ""
        For iCol = 1 To iNbrCol
            sRecord = sRecord & vColumnValues(iLig, iCol) & hSep
        Next
        Print #iFp, sRecord
    Next
    Close iFp
End Sub

Sub exportToXML(hFileName As String, Optional hReplace As Integer = True)
    Const PROTOCOL = "<?xml version=""1.0"" encoding=""UTF-8"" ?>"
    Dim iFp As Integer
    Dim vHeaders As Variant
    Dim sRecord As String
    Dim iLig As Long
    Dim iCol As Integer
    Dim iNbrLig As Long
    Dim iNbrCol As Integer
    Dim vColumnValues As Variant
    Dim sZeroes As String
    Dim iRepeat As Long
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    iFp = FreeFile
    Open hFileName For Output As iFp
    Print #iFp, PROTOCOL
    Print #iFp, "<" & pNameTS & ">"
    vColumnValues = getTableCells
    sRecord = ""
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    iNbrLig = pDataBody.Rows.Count + 1
    iNbrCol = pDataBody.Columns.Count
    vHeaders = getHeaders()
    iRepeat = Len(CStr(pNbRows))
    sZeroes = String(iRepeat, "0")
    For iLig = 2 To iNbrLig
        sRecord = ""
        Print #iFp, "<RECORD id=""" & Right(sZeroes & iLig - 1, iRepeat) & """>"
        For iCol = 1 To iNbrCol
            sRecord = Chr(9) & "<" & vHeaders(iCol - 1) & ">" & vColumnValues(iLig, iCol) & "</" & vHeaders(iCol - 1) & ">"
            Print #iFp, sRecord
        Next
        Print #iFp, "</RECORD>"
    Next
    Print #iFp, "</" & pNameTS & ">"
    Close iFp
End Sub


Sub exportToJSON(hFileName As String, Optional hReplace As Integer = True)
    Const DEBUT_TABLEAU = "["
    Const FIN_TABLEAU = "]"
    Const DEBUT_RECORD = "{"
    Const FIN_RECORD = "}"
  
    Dim iFp As Integer
    Dim vHeaders As Variant
    Dim sRecord As String
    Dim sVirgule As String
    Dim iLig As Long
    Dim iCol As Integer
    Dim iCptLig As Long
    Dim iCptCol As Integer
    Dim iNbrLig As Long
    Dim iNbrCol As Integer
    Dim vColumnValues As Variant
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    iFp = FreeFile

    vColumnValues = getTableCells
    sRecord = ""
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    iNbrLig = pDataBody.Rows.Count + 1
    iNbrCol = pDataBody.Columns.Count
    vHeaders = getHeaders()
    iCptLig = 1
    Open hFileName For Output As iFp
    Print #iFp, DEBUT_TABLEAU
    For iLig = 2 To iNbrLig
        iCptLig = iCptLig + 1
        iCptCol = 0
        Print #iFp, DEBUT_RECORD
        sRecord = ""
        sVirgule = ""
        For iCol = 1 To iNbrCol
            iCptCol = iCptCol + 1
            If iCptCol <> iNbrCol Then sVirgule = "," Else sVirgule = ""
            sRecord = Chr(34) & vHeaders(iCol - 1) & Chr(34) & ": " & Chr(34) & vColumnValues(iLig, iCol) & Chr(34) & sVirgule
            Print #iFp, sRecord
        Next
        If iCptLig <> iNbrLig Then sVirgule = "," Else sVirgule = ""
        Print #iFp, FIN_RECORD & sVirgule

    Next
    Print #iFp, FIN_TABLEAU
    Close iFp
End Sub

' V1.02
Sub RefreshConnection(Optional hBackgroundQuery As Boolean = False)
    pQueryTableWorkbookConnection.OLEDBConnection.BackgroundQuery = hBackgroundQuery
    pQueryTableWorkbookConnection.Refresh
End Sub

Sub RefreshTable(Optional hBackgroundQuery As Boolean = False)
    pQueryTable.BackgroundQuery = hBackgroundQuery
    pQueryTable.Refresh
End Sub

Function quickEraseTable(Optional hAjout As Boolean = True) As Boolean
' V1.01
    Dim rTableau As Range
    Dim rBodyRange As Range
    quickEraseTable = False
    Set rTableau = Range(pNameTS)
    Set rBodyRange = rTableau.ListObject.DataBodyRange
    If Not rBodyRange Is Nothing Then Call rBodyRange.Delete
    If hAjout Then Call addInsertLinesTS(0)
    quickEraseTable = True
End Function

Function addInsertLinesTS(Optional hLigne As Long = 0) As Boolean
    Dim rTableau As Range
    addInsertLinesTS = False
    Set rTableau = Range(pNameTS)
    If addLinesTS(rTableau, hLigne) Then
        addInsertLinesTS = True
    End If
End Function

Private Function addLinesTS(hTS As Range, Optional ByVal hLigne As Long = 0) As Boolean
    Dim iLigne As Integer
    addLinesTS = False
    Err.Clear
    iLigne = 0
    If hLigne <> 0 Then
        iLigne = initIndex(hTS, hLigne)
        If iLigne = -1 Then
            Exit Function
        End If
    End If
    Select Case iLigne
        Case 0
            If hTS.ListObject.ListRows.Count = 0 Then
                Set hTS = hTS.ListObject.ListRows.Add.Range
            Else
                hTS.ListObject.ListRows.Add
            End If
            addLinesTS = True
        Case 1 To hTS.ListObject.ListRows.Count
            hTS.ListObject.ListRows.Add iLigne
            addLinesTS = True
    End Select
End Function

Function insertValuesTS(hValue As Variant, _
Optional hAjoutLigne As Boolean = False, _
Optional hLig As Long = 0, _
Optional hCol As Integer = 1, _
Optional hDimValue As Integer = 0) As Boolean

    Dim rTableau As Range
    Dim lngNbRows As Long
    Dim lngRow As Long
    Dim iCol As Integer
    Dim idxLig As Integer
    Dim iDx As Integer
    insertValuesTS = False
    If hAjoutLigne Then
        If Not addInsertLinesTS(hLig) Then Exit Function
    End If
    Set rTableau = Range(pNameTS)
    lngNbRows = rTableau.ListObject.ListRows.Count
    If hLig > lngNbRows Then
        Exit Function
    End If
    If hLig = 0 Then
        lngRow = lngNbRows
    Else
        lngRow = hLig
    End If
    iCol = hCol
    If IsArray(hValue) Then
        Select Case hDimValue
        Case 0, 1
            For iDx = LBound(hValue) To UBound(hValue)
                rTableau.ListObject.DataBodyRange(lngRow, iDx + 1) = hValue(iDx)
            Next
        Case 2
            For idxLig = LBound(hValue) To UBound(hValue)
                For iDx = LBound(hValue, 2) To UBound(hValue, 2)
                    rTableau.ListObject.DataBodyRange(lngRow, iDx + 1) = hValue(idxLig, iDx)
                Next
            Next
        End Select
    Else
        rTableau.ListObject.DataBodyRange(lngRow, iCol) = hValue
    End If
    insertValuesTS = True
End Function

Private Function initIndex(hTS As Range, hLigne As Long) As Long
    initIndex = False
    If hLigne = 0 Then hLigne = hTS.ListObject.ListRows.Count
    If hLigne < 0 Or hLigne > hTS.ListObject.ListRows.Count Then
        initIndex = -1
    Else
        initIndex = hLigne
    End If
End Function


'*************************************************************************************
'* exportToXML2, IndenterXMLCode, exportToHTML
'* Auteur : Patrick TOULON sur https://excel-downloads.com/
'* Tous mes remerciements pour sa collaboration et échanges de lignes de code
'* Ajout à cette version 1.03 le 01/05/2025
'*************************************************************************************
Sub exportToHTML(hFileName As String, Optional hReplace As Integer = True)
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim iNbrLig As Long
    Dim iNbrCol As Integer
    Dim vColumnValues As Variant
    Dim table, TR, TD, TH, COLHTML, Tbody, COL
    Dim CdeHTML As String
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    vColumnValues = getTableCells
    iNbrLig = pDataBody.Rows.Count + 1
    iNbrCol = pDataBody.Columns.Count
    vHeaders = getHeaders()

    With CreateObject("htmlfile")
        Set table = .body.appendchild(.createelement("TABLE"))
        table.setattribute "Tableau", CStr(pNameTS)
        table.Style.bordercollapse = "collapse"
        table.Style.TextAlign = "center"
        For c = 0 To UBound(vHeaders)
            Set COL = table.appendchild(.createelement("COL"))
            COL.Style.Width = Round(pDataBody.Cells(1, c + 1).Width) & "pt"
        Next
        Set Tbody = table.appendchild(.createelement("TBODY"))
        Set TR = Tbody.appendchild(.createelement("TR"))
        For c = 0 To UBound(vHeaders)
            Set TH = TR.appendchild(.createelement("TH"))
            TH.innerhtml = CStr(vHeaders(c))
            TH.Style.Border = "0.5pt solid black"
        Next
        For i = 2 To iNbrLig
            Set TR = Tbody.appendchild(.createelement("TR"))
            For c = 1 To iNbrCol
                Set TD = TR.appendchild(.createelement("TD"))
                TD.innerhtml = vColumnValues(i, c)
                TD.Style.Border = "0.5pt solid black"
            Next
        Next
        'Debug.Print .body.innerhtml

        Dim oStream
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText table.outerhtml
        oStream.SaveToFile hFileName, 2
    End With
End Sub

Sub exportToXML2(hFileName As String, Optional hReplace As Integer = True)
    'Auteur :patricktoulon
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim iNbrLig As Long
    Dim iNbrCol As Integer
    Dim vColumnValues As Variant
    Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close

    vColumnValues = getTableCells
    iNbrLig = pDataBody.Rows.Count + 1
    iNbrCol = pDataBody.Columns.Count
    vHeaders = getHeaders()
    Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
    With XmlDoc
        Set ROOT = .appendchild(.createelement(CStr(pNameTS))) 'CREATION DE L'ELEMENT ROOT
        'creation et intégration du post processing
        Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
        .InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing
        'ajout des elements
        For i = 2 To iNbrLig
            Set Record = ROOT.appendchild(.createelement("RECORD_0" & i - 1))
            For c = 1 To iNbrCol
                Set elem = Record.appendchild(.createelement(pDataBody.Cells(1, c).Offset(-1)))
                elem.Text = pDataBody.Cells(i - 1, c)
            Next
        Next

        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText IndenterXMLCode(XmlDoc.XML)
        oStream.SaveToFile hFileName, 2
    End With
End Sub

'*************************************************************************************
'version 2 en memoire
'Fonction basique minimale pour indenter un code xml(issue de creatorribbonx (collection fonction perso patricktoulon))
'* Auteur : Patrick TOULON sur https://excel-downloads.com/
'*************************************************************************************
Public Function IndenterXMLCode(ByVal vDomOrString As Variant) As String
    Dim XMLWriter As Object ' MSXML2.MXXMLWriter
    On Error GoTo QH
    Set XMLWriter = CreateObject("MSXML2.MXXMLWriter")
    XMLWriter.indent = True 'ajoute l'attribut indent
    With CreateObject("MSXML2.SAXXMLReader")
        Set .contentHandler = XMLWriter
        .Parse vDomOrString
    End With
    IndenterXMLCode = Replace(Replace(XMLWriter.output, "UTF-16", "UTF-8"), "standalone=""no""", "")
    Exit Function
QH:
End Function

'*************************************************************************
'* Ajout Patrick TOULON à propos des exports xml e html
'*************************************************************************

'*************************************************************************************
'* Export d'un tableau au format image
'* Auteur : Patrick TOULON sur https://excel-downloads.com/
'* Tous mes remerciements pour collaboration et échanges de lignes de code
'* Ajout à cette version 1.04 le 01/05/2025
'*************************************************************************************
Sub exportToImagefile(hFileName As String, Optional hReplace As Integer = True, Optional header As Boolean = False)
   'patricktoulon
   Dim Graph As Chart
    Dim pl As Range
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    If header Then
        Set pl = pDataBody.Offset(-1).Resize(pDataBody.Rows.Count + 1)
    Else
        Set pl = pDataBody
    End If
    pl.CopyPicture 'on reste en xlpicture(meilleure qualité)
    Set Graph = ActiveSheet.ChartObjects.Add(0, 0, 0, 0).Chart
    ActiveSheet.Shapes(Graph.Parent.Name).Line.Visible = msoFalse
    With Graph.Parent
        .Width = pl.Width: .Height = pl.Height: .Left = pl.Width + 20:
        .Select
        .Activate
        Do: DoEvents
        .Chart.Paste
    Loop While .Chart.Pictures.Count = 0
    'le format depend de l'extension
    .Chart.Export hFileName, Right(hFileName, 3)
End With
Graph.Parent.Delete
End Sub

Sub exportToImagefile_02(hFileName As String, _
Optional hReplace As Integer = True, Optional hHeader As Boolean = False)
' Version un peu plus basique mais qui fonctionne

    Const TEMP = "_$$$$§§temp§§$$$$_" ' ça ne risque pas d'être choisi par un utilisateur Lambda
    Dim rRangeToPicture As Range
    Dim sExt As String
  
    Dim oTString As Cls_ToolsStrings
    Set oTString = New Cls_ToolsStrings
    sExt = oTString.StringRightBack(hFileName, ".")
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
                ERROR_MESSAGE, _
                ERROR_SOURCE, _
                ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
  
    ' Pour rester cohérent avec la version 01 proposée
    '--------------------------------------------------
    If hHeader Then
        Set rRangeToPicture = pRange ' on récupère tout le tableau avec un Range #All
    Else
        Set rRangeToPicture = pDataBody
    End If
  
    rRangeToPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  
    With ActiveSheet.ChartObjects.Add(Left:=rRangeToPicture.Left, Top:=rRangeToPicture.Top, _
        Width:=rRangeToPicture.Width, Height:=rRangeToPicture.Height)
        .Name = TEMP
        .Activate
    End With
  
    ActiveChart.Paste
    ActiveSheet.ChartObjects(TEMP).Chart.Export hFileName, sExt
    ActiveSheet.ChartObjects(TEMP).Delete

End Sub

Sub exportToImagefile_03(hFileName As String, _
Optional hReplace As Integer = True, Optional hHeader As Boolean = False)

    Dim rRangeToPicture As Range
    Dim oChart As Chart
    Dim sExt As String
  
    Dim oTString As Cls_ToolsStrings
    Set oTString = New Cls_ToolsStrings
    sExt = oTString.StringRightBack(hFileName, ".")
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
                ERROR_MESSAGE, _
                ERROR_SOURCE, _
                ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
  
    ' Pour rester cohérent avec la version 01 proposée
    '--------------------------------------------------
    If hHeader Then
        Set rRangeToPicture = pRange ' on récupère tout le tableau avec un Range #All
    Else
        Set rRangeToPicture = pDataBody
    End If
  
    rRangeToPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Set oChart = ActiveSheet.ChartObjects.Add(rRangeToPicture.Left, _
        rRangeToPicture.Top, _
        rRangeToPicture.Width, _
        rRangeToPicture.Height).Chart
      
    With oChart
        .Parent.Activate
        .ChartArea.Format.Line.Visible = msoFalse
        .Paste
        .Export hFileName, sExt
        .Parent.Delete
    End With

End Sub

Sub exportToPDF(hFileName As String, Optional hReplace As Integer = True, _
Optional hHeader As Boolean = False, _
Optional hMEP As Boolean = False, _
Optional hOrientation As XlOrientation = xlLandscape, Optional hZoom As Integer = 100)

    Dim rRangeToPDF As Range
  
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
                ERROR_MESSAGE, _
                ERROR_SOURCE, _
                ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
  
    ' Pour rester cohérent avec la version 01 proposée
    '--------------------------------------------------
    If hHeader Then
        Set rRangeToPDF = pRange ' on récupère tout le tableau avec un Range #All
    Else
        Set rRangeToPDF = pDataBody
    End If
  
    '---------------------------------------
    ' Si mise en page - formatage minimum
    ' à ajuster selon les besoins
    '---------------------------------------
  
    If hMEP Then
        With ActiveSheet.PageSetup
            .LeftHeader = pNameTS
            .CenterHeader = "&P/&N"
            .RightHeader = "&D"
            .LeftFooter = "&A"
            .CenterFooter = "&F"
            .Zoom = hZoom
            .Orientation = hOrientation
        End With
    Else
        ' On va remettre les valeurs par défaut - aucune mise en page
        With ActiveSheet.PageSetup
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .Zoom = 100
            .Orientation = xlPortrait
        End With
    End If
  
    rRangeToPDF.ExportAsFixedFormat _
         Type:=xlTypePDF, _
         Filename:=hFileName, _
         Quality:=xlQualityStandard, _
         IncludeDocProperties:=True, _
         IgnorePrintAreas:=False, _
         OpenAfterPublish:=False
      
End Sub

Function createTSFromCells(hWk As Worksheet, hCell As String, _
hNomTS As String, _
Optional hStyle As String = "TableStyleLight1", _
Optional hHead As XlYesNoGuess = xlYes) As Range

    Dim rCell As Range
    Dim rCellTS As Range
    Dim sTmpName As String
  
    Set rCell = hWk.Range(hCell)
    Set rCellTS = rCell.CurrentRegion
  
    '******************************************************************************
    '* Précaution si on tente à nouveau la manoeuvre de récréer ce même tableau
    '* il faut le protéger et empêcher sa création pour éviter un message d'erreur
    '* test peut-être basque mais qui fonctionne
    '******************************************************************************
    If pOTools.objWbExists(ThisWorkbook, hNomTS) Then
            Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le tableau " & hNomTS & " existe déjà"
    End If

    If rCell.ListObject Is Nothing Then
        rCellTS.Parent.ListObjects.Add(xlSrcRange, rCellTS, , hHead).Name = hNomTS
        rCellTS.Parent.ListObjects(rCellTS.ListObject.Name).TableStyle = hStyle
    End If
  
    '---------------------------------------------------------------
    ' On renvoie soit le tableau créé soit le tableau déjà existant
    '---------------------------------------------------------------
    Set createTSFromCells = rCellTS
End Function

Sub exportToExcel(hFileName As String, _
Optional hReplace As Integer = True, _
Optional hHeader As Boolean = False)

    Dim rRangeToExcel As Range
    Dim oXL As Excel.Application
      
    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
                ERROR_MESSAGE, _
                ERROR_SOURCE, _
                ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
  
    If hHeader Then
        Set rRangeToExcel = pRange ' on récupère tout le tableau avec un Range #All
    Else
        Set rRangeToExcel = pDataBody
    End If
    Set oXL = Nothing ' un peu de ménage
    Set oXL = CreateObject("excel.application") ' on lance une session Excel
    oXL.Visible = False ' on la masque
    oXL.Workbooks.Add ' on crée le nouveau classeur
    rRangeToExcel.Copy ' On copie en mémoire les cellules à déposer dans le classeur
    oXL.ActiveSheet.Paste ' On dépose dans le 1er onglet à disposition
    oXL.DisplayAlerts = False ' pout s'éviter le message d'alerte
    oXL.ActiveWorkbook.SaveAs hFileName ' enregistrement du fichier
    oXL.ActiveWorkbook.Close ' on ferme tout !
    oXL.DisplayAlerts = True
    Set oXL = Nothing ' un peu de ménage
End Sub

VB:

Option Explicit

'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'* Vérifie si la feuille qui héberge le tableau existe
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Function wkExist(hWb As Workbook, hWKName As String) As Boolean
    Dim wkItem As Worksheet
    wkExist = False
    For Each wkItem In hWb.Worksheets
        If UCase(wkItem.Name) = UCase(hWKName) Then
            wkExist = True
            Exit For
        End If
    Next
End Function

'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'* Vérifie si l'objet existe
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Function objExist(hWk As Worksheet, hObjame As String) As Boolean
    Dim objItem As Object
    objExist = False
    For Each objItem In hWk.ListObjects
        If UCase(objItem.Name) = UCase(hObjame) Then
            objExist = True
            Exit For
        End If
    Next
End Function

Function objWbExists(hWb As Workbook, hObjame As String) As Boolean
    Dim objItem As Object
    Dim wk As Worksheet
    objWbExists = False
    For Each wk In hWb.Worksheets
        For Each objItem In wk.ListObjects
            If UCase(objItem.Name) = UCase(hObjame) Then
                objWbExists = True
                Exit Function
            End If
        Next
    Next
End Function

'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'* Vérifie si le tableau nommé existe
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Function existsRANGE(hRange As String) As Boolean
    Dim wb As Workbook
    Dim v As Name
    existsRANGE = False
    Set wb = ActiveWorkbook
    For Each v In wb.Names
        If v.Name = hRange Then
            existsRANGE = True
            Exit Function
        End If
    Next
End Function

'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'* Vérifie si l'objet tableau existe
'*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Function exitsTS(hTS As String) As Boolean
    Dim wb As Workbook
    Dim wk As Worksheet
    Dim obj As ListObject
    Set wb = ActiveWorkbook
    exitsTS = False
    For Each wk In wb.Worksheets
        For Each obj In wk.ListObjects
            If hTS = obj.Name Then
                exitsTS = True
                Exit Function
            End If
        Next
    Next
End Function

Function existsColumnName(hHeaders As Variant, hColName As String) As Boolean
    Dim vName As Variant
    existsColumnName = False
    For Each vName In hHeaders
        If vName = hColName Then
            existsColumnName = True
            Exit For
        End If
    Next
End Function

Function isFileExists(szFile As String) As Boolean
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    isFileExists = oFSO.FileExists(szFile)
End Function

Function isFolderExists(szFolder As String)
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    isFolderExists = oFSO.FolderExists(szFolder)
End Function

Function isFolderExists2(sDossier As String)
    If sDossier <> "" And Len(Dir(sDossier, vbDirectory)) > 0 Then
       isFolderExists2 = True
    Else
       isFolderExists2 = False
    End If
End Function

Function isExistsWorkbookQuery(hWBQuery As WorkbookQuery, hName As String) As Boolean
    Dim oWbQuery As WorkbookQuery
    isExistsWorkbookQuery = False
    For Each oWbQuery In ThisWorkbook.Queries
        If hName = oWbQuery.Name Then
            isExistsWorkbookQuery = True
            Exit For
        End If
    Next
End Function

Function IsExistsQueryTable(hWk As String, hQueryTable As String) As Boolean
    Dim oListObject As ListObject
    Dim oQueryTable As QueryTable

    IsExistsQueryTable = False
    Set oQueryTable = Nothing
    Set oListObject = Nothing
    If Not objWbExists(ThisWorkbook, hQueryTable) Then
        Exit Function
    End If
    Set oListObject = ThisWorkbook.Worksheets(hWk).ListObjects(hQueryTable)
    On Error Resume Next
    Set oQueryTable = oListObject.QueryTable
    If Not oQueryTable Is Nothing Then
        IsExistsQueryTable = True
    End If
    On Error GoTo -1
End Function

VB:

Option Explicit

Function StringLeft(hSourceString As String, hSearchString As String) As String
    Dim iPos As Integer
    iPos = InStr(hSourceString, hSearchString)
    If iPos > 0 Then iPos = iPos - 1
    StringLeft = Left(hSourceString, iPos)
End Function

Function StringRight(hSourceString As String, hSearchString As String) As String
    Dim iPos As Integer
    Dim iStart As Integer
    Dim iLen As Integer
    iPos = InStr(hSourceString, hSearchString)
    iLen = Len(hSourceString)
    iStart = iLen - iPos
    StringRight = Right(hSourceString, iStart)
End Function

Function StringLeftBack(hSourceString As String, hSearchString As String) As String
    Dim sSourceStringBack As String
    Dim sSearchStringBack As String
    Dim sTurnBack As String
    Dim iPos As Integer
    Dim iNdx As Integer
    Dim iLengthString As Integer
    Dim iStartString As Integer
    Dim sTmpResult As String

    For iNdx = Len(hSourceString) To 1 Step -1
        sSourceStringBack = sSourceStringBack & Mid(hSourceString, iNdx, 1)
    Next
    For iNdx = Len(hSearchString) To 1 Step -1
        sSearchStringBack = sSearchStringBack & Mid(hSearchString, iNdx, 1)
    Next
    iPos = InStr(sSourceStringBack, sSearchStringBack)
    iLengthString = Len(sSourceStringBack)
    iStartString = iLengthString - iPos
    sTmpResult = Right(sSourceStringBack, iStartString)
    For iNdx = Len(sTmpResult) To 1 Step -1
        sTurnBack = sTurnBack & Mid(sTmpResult, iNdx, 1)
    Next
    StringLeftBack = sTurnBack
End Function
 
Function StringRightBack(hSourceString As String, hSearchString As String) As String
    Dim sSourceStringBack As String
    Dim sSearchStringBack As String
    Dim sTurnBack As String
    Dim iPos As Integer
    Dim iNdx As Integer
    Dim iLengthString As Integer
    Dim iStartString As Integer
    Dim sTmpResult As String

    For iNdx = Len(hSourceString) To 1 Step -1
        sSourceStringBack = sSourceStringBack & Mid(hSourceString, iNdx, 1)
    Next
    For iNdx = Len(hSearchString) To 1 Step -1
        sSearchStringBack = sSearchStringBack & Mid(hSearchString, iNdx, 1)
    Next
    iPos = InStr(sSourceStringBack, sSearchStringBack)
    If iPos > 0 Then iPos = iPos - 1
    sTmpResult = Left(sSourceStringBack, iPos)
    For iNdx = Len(sTmpResult) To 1 Step -1
        sTurnBack = sTurnBack & Mid(sTmpResult, iNdx, 1)
    Next
    StringRightBack = sTurnBack
 End Function

VB:

Option Explicit

'**************************************************************************
'*  Mode d'utilisation de la classe CLS_TS sur les tableaux structurés
'* Auteur    : OGURUMA
'* Date      : 21/04/2025
'* Version   : Initiale
'***************************************************************************


    Const TBL_TS = "TBL_RAYON_DEMO"
    Const TBL_TS_02 = "TBL_RAYON_DEMO_02"
    Const TBL_TS_03 = "RQTBL_RAYON_DEMO_03"
    Const TBL_TS_04 = "TBL_RAYON_DEMO_03"
    Const FEUILLE_TS = "DEMO_CLASS_CLS_TS"
    Const FEUILLE_TS_02 = "DEMO_CLASS_CLS_TS_02"
    Const FEUILLE_TS_03 = "RQ_RAYON_DEMO_03"
    Const FEUILLE_TS_04 = "DEMO_CLASS_CLS_TS_03"
  
    Dim oTS As CLS_TS
  
    Dim vHeaders As Variant
    Dim vColumnValues As Variant
    Dim vValue As Variant
    Dim vVariant As Variant
  
    Dim oListRows As ListRows
    Dim oRow As ListRow
    Dim oListColumns As ListColumns
    Dim oColumn As ListColumn
  
'*************************************************************
'* Tests de la version 1.0
'*************************************************************
  
Sub INSTANCIATE()
    Set oTS = New CLS_TS
    '****************************************
    ' peut être passé comme ceci
    ' Call oTS.Instantiate("TBL_RAYON_1")
    ' par défaut c'est la feuille active
    '****************************************
    Call oTS.Instantiate(TBL_TS, FEUILLE_TS)
    MsgBox "OK INSTANCIATE"
End Sub
Sub INSTANCIATE_02()
    Set oTS = New CLS_TS
    '****************************************
    ' peut être passé comme ceci
    ' Call oTS.Instantiate("TBL_RAYON_1")
    ' par défaut c'est la feuille active
    '****************************************
    Call oTS.Instantiate(TBL_TS_02, FEUILLE_TS_02)
    MsgBox "OK INSTANCIATE"
End Sub

 
Sub test_class()
  
    Call INSTANCIATE
  
    MsgBox "Nom : " & oTS.Name
    MsgBox "Address : " & oTS.Address
    MsgBox "Nbr Rows : " & oTS.getNbrows()
    MsgBox "Nbr Columns : " & oTS.getNbColumns
End Sub

Sub Headers()
Call INSTANCIATE
    vHeaders = oTS.Headers
    MsgBox oTS.getHeaderToString()
    MsgBox oTS.getHeaderToString("-")
End Sub

Sub clearcontents()
Call INSTANCIATE
   ' en commentaire mais ça fonctionne - pour le conserver
   ' Call oTS.DataBodyClearContents
   MsgBox "fonctionne mais mis en commentaire"
End Sub

Sub get_object_data()
Call INSTANCIATE
    MsgBox "Nbr de valeurs : " & oTS.getDataBodyCount
    MsgBox "Nbr de valeurs : " & oTS.getDataBodyCellsCount
    MsgBox "Nbr de valeurs + entête de colonnes : " & oTS.getObjectTableCount
    MsgBox "5ème élement de la colonne RAYON_1 : " & oTS.getObjectTableColumnItem("RAYON_1", 5)
    MsgBox "Index de la colonne RAYON_1 : " & oTS.getObjectTableColumnIndex("RAYON_1")
End Sub

Sub getObjectTableColumnCells()
Call INSTANCIATE
    Dim sStr As String
    vColumnValues = oTS.getObjectTableColumnCells("RAYON_1")
    For Each vValue In vColumnValues
        sStr = sStr & " " & vValue
    Next
    MsgBox sStr
End Sub

Sub getDataBodyColumnCells_1()
Call INSTANCIATE
    Dim sStr As String
    vColumnValues = oTS.getDataBodyColumnCells(1)
    For Each vValue In vColumnValues
        sStr = sStr & " " & vValue
    Next
    MsgBox sStr
End Sub

Sub getDataBodyRowCells_5()
Call INSTANCIATE
    Dim sStr As String
    vColumnValues = oTS.getDataBodyRowCells(5)
    For Each vValue In vColumnValues
        sStr = sStr & " " & vValue
    Next
    MsgBox sStr
    MsgBox "Ligne 5, colonne 3 : " & oTS.getDataBodyRowCellsValue(5, 3)
End Sub

Sub getDataCells()
Call INSTANCIATE
    Dim sStr As String
    Dim iLig As Long
    Dim iCol As Integer
    MsgBox "Nbr Rows : " & oTS.getNbrows()
    MsgBox "Nbr Columns : " & oTS.getNbColumns
    vColumnValues = oTS.getDataCells
    For Each vValue In vColumnValues
        sStr = sStr & " " & vValue
    Next
    MsgBox sStr
    sStr = ""
    For iLig = 1 To oTS.getNbrows()
        For iCol = 1 To oTS.getNbColumns
            sStr = sStr & " " & vColumnValues(iLig, iCol)
        Next
        sStr = sStr & vbLf
    Next
    MsgBox sStr
End Sub

Sub getTableCells()
Call INSTANCIATE
    Dim sStr As String
    Dim iLig As Long
    Dim iCol As Integer
    ' par la table on récupère la ligne des noms de colonnes
    ' à la ligne 1
    '-------------------------------------------------------
    MsgBox "getTableNbrows = " & oTS.getTableNbrows
    vColumnValues = oTS.getTableCells
    For Each vValue In vColumnValues
        sStr = sStr & " " & vValue
    Next
    MsgBox sStr
    sStr = ""
    For iLig = 1 To oTS.getNbrows() + 1
        For iCol = 1 To oTS.getNbColumns
            sStr = sStr & " " & vColumnValues(iLig, iCol)
        Next
        sStr = sStr & vbLf
    Next
    MsgBox sStr
    sStr = ""
    For iLig = 2 To oTS.getNbrows() + 1
        For iCol = 1 To oTS.getNbColumns
            sStr = sStr & " " & vColumnValues(iLig, iCol)
        Next
        sStr = sStr & vbLf
    Next
    MsgBox sStr
End Sub

Sub getTableListRows()
Call INSTANCIATE
    Dim sStr As String
    Dim iLig As Long
    Dim iCol As Integer
    sStr = ""
    Set oListRows = oTS.getTableListRows
    For Each oRow In oListRows
        sStr = sStr & " Index " & oRow.Index & " : " & oRow.Range(1, 1) & _
         " " & oRow.Range(1, 2) & _
         " " & oRow.Range(1, 3) & _
         " " & oRow.Range(1, 4) & _
         " " & oRow.Range(1, 5) & _
         " " & oRow.Range(1, 6) & vbLf
    Next
    MsgBox sStr

End Sub

Sub getTableListColumns()
Call INSTANCIATE
    Dim sStr As String
    Dim iLig As Long
    Dim iCol As Integer
    sStr = ""
    Set oListColumns = oTS.getTableListColumns
    For Each oColumn In oListColumns
        sStr = sStr & " " & oColumn.Range(1, 1)
    Next
    MsgBox sStr
End Sub

Sub getDataSumColumn()
Call INSTANCIATE
    MsgBox "Total de la colonne 5 RAYON_5 : " & oTS.getDataSumColumn(5)
End Sub

Sub getDataSumRow()
Call INSTANCIATE
    MsgBox "Total de la ligne 5 : " & oTS.getDataSumRow(5)
End Sub

Sub setDataFilter()
Call INSTANCIATE
    Call oTS.setDataFilter(1, "Prod_5", "=")
End Sub
Sub setDataFilter_2()
Call INSTANCIATE
    Call oTS.setDataFilter(3, "498", ">")
End Sub

Sub activateDataFilter()
Call INSTANCIATE
    Call oTS.activateDataFilter
End Sub

Sub showAllDataFilter()
Call INSTANCIATE
    Call oTS.showAllDataFilter
End Sub

Sub isInteriorTS()
Call INSTANCIATE
    If oTS.isIntoTS Then
        MsgBox "dans le tableau"
    Else
        MsgBox "pas dans le tableau"
    End If
End Sub

Sub xLookupData()
Call INSTANCIATE
    Dim vRes As Variant
    vRes = oTS.xLookupData(1, "Prod_5")
    MsgBox vRes(0) & vbLf & _
    vRes(1) & vbLf & _
    vRes(2) & vbLf & _
    vRes(3) & vbLf & _
    vRes(4)
    Debug.Print
End Sub

Sub xLookupThrowAllData()
Call INSTANCIATE
    Dim vRes As Variant
    vRes = oTS.xLookupThrowAllData("715")
    MsgBox vRes(0) & vbLf & _
    vRes(1) & vbLf & _
    vRes(2) & vbLf & _
    vRes(3) & vbLf & _
    vRes(4) & vbLf & _
    vRes(5)
    Debug.Print
End Sub

Sub isTheColumnExists()
Call INSTANCIATE
    If oTS.isColumnExists("PRODUIT") Then
        MsgBox "PRODUIT existe"
    Else
        MsgBox "Inconnue"
    End If
End Sub

Sub setColumnsValuesByName()
Call INSTANCIATE
    Randomize
    Call oTS.setColumnsValuesByName("RAYON_5", Int(1000 * Rnd))
End Sub

Sub setColumnsValuesByIndex()
Call INSTANCIATE
    Randomize
    Call oTS.setColumnsValuesByIndex(6, Int(1000 * Rnd))
End Sub

Sub setRowsValuesByIndex()
Call INSTANCIATE
    Randomize
    Call oTS.setRowsValuesByIndex(6, Int(1000 * Rnd), True)
End Sub

Sub setRowsValuesByIndexV2()
Call INSTANCIATE
    Randomize
    Call oTS.setRowsValuesByIndexV2(6, Int(1000 * Rnd), 3)
End Sub

Sub deleteRows()
Call INSTANCIATE
    Call oTS.deleteRows(5)
    MsgBox "ligne 5 supprimée"
End Sub

Sub showRowTotal()
Call INSTANCIATE
    Call oTS.showRowTotal
End Sub

Sub hideRowTotal()
Call INSTANCIATE
    Call oTS.hideRowTotal
End Sub

Sub eraseTable()
Call INSTANCIATE
    Call oTS.eraseTable
    MsgBox "effacé, recopier copier/coller le tableau dans DEMO_03"
End Sub

Sub addInsertLinesTS()
Call INSTANCIATE
    Call oTS.addInsertLinesTS
End Sub

Sub addInsertLinesTS_2()
Call INSTANCIATE
    Call oTS.addInsertLinesTS(2)
End Sub

Sub addInsertLinesTS_Dim1()
Call INSTANCIATE
    Dim vTabl() As Variant
    ReDim Preserve vTabl(6)
    vTabl(0) = "PROD_NEW"
    vTabl(1) = 100
    vTabl(2) = 200
    vTabl(3) = 300
    vTabl(4) = 400
    vTabl(5) = 500
    vTabl(6) = 600
  
    Call oTS.insertValuesTS(vTabl, True, 0, 3, 1)
End Sub

Sub addInsertLinesTS_Dim2()
Call INSTANCIATE
    Dim vTabl() As Variant
    ReDim Preserve vTabl(0, 6)
    vTabl(0, 0) = "NEW_" & Format(Now, "hh:mm:ss")
    vTabl(0, 1) = 10000
    vTabl(0, 2) = 2000
    vTabl(0, 3) = 3000
    vTabl(0, 4) = 4000
    vTabl(0, 5) = 5000
    vTabl(0, 6) = 6000
    Call oTS.insertValuesTS(vTabl, True, 0, 0, 2)
End Sub

Sub addInsertLinesTS_Dim21()
Call INSTANCIATE
    Dim vTabl() As Variant
    ReDim Preserve vTabl(0, 6)
    vTabl(0, 0) = "NEW_" & Format(Now, "hh:mm:ss")
    vTabl(0, 1) = 10000
    vTabl(0, 2) = 2000
    vTabl(0, 3) = 3000
    vTabl(0, 4) = 4000
    vTabl(0, 5) = 5000
    vTabl(0, 6) = 6000
    Call oTS.insertValuesTS(vTabl, False, 0, 0, 2)
End Sub

'*************************************************************
'* Tests de la version 1.01
'*************************************************************

Sub quickEraseTable()
Call INSTANCIATE_02
    Call oTS.quickEraseTable
    MsgBox "table effacée récuper les données du tableau dans la feuille demo_03"
End Sub

Sub autresProprietes()
Call INSTANCIATE_02
    MsgBox "NameWK = " & oTS.NameWk & vbLf & _
    "HeaderAddress =  " & oTS.HeaderAddress & vbLf & _
    "HeaderRow = " & oTS.HeaderRow & vbLf & _
    "HeaderColumn = " & oTS.HeaderColumn & vbLf & _
    "DataRow = " & oTS.DataRow & vbLf & _
    "DataColumn = " & oTS.DataColumn
End Sub

Sub activateDataFilter_02()
Call INSTANCIATE_02
    Call oTS.activateDataFilter
End Sub

Sub deactivateDataFilter_02()
Call INSTANCIATE_02
    Call oTS.deactivateDataFilter
End Sub

Sub resizeTS()
Call INSTANCIATE_02
    Call oTS.resizeTS("$A$5:$h$30")
    MsgBox "ok"
    Call oTS.resizeTS("$A$5:$g$15")
    MsgBox "ok"
    MsgBox "le prochain sera KO"
    Call oTS.resizeTS("$z$100:$g$15")
End Sub

Sub exportToCSV_01()
Call INSTANCIATE_02
    Call oTS.exportToCSV("D:\DATA\TestExportToCsv01.csv", , False)
End Sub

Sub exportToCSV_02()
Call INSTANCIATE_02
    Call oTS.exportToCSV("D:\DATA\TestExportToCsv02.csv", Chr(9), True)
End Sub

Sub getHeaders()
Call INSTANCIATE_02
    Call oTS.getHeaders
End Sub

Sub exportToXML_01()
Call INSTANCIATE_02
    Call oTS.exportToXML("D:\DATA\TestExportToXML.xml", True)
End Sub

Sub exportToJSON_01()
Call INSTANCIATE_02
    Call oTS.exportToJSON("D:\DATA\TestExportToJSON.json", True)
End Sub

'*************************************************************
'* Tests de la version 1.02
'*************************************************************
Sub INSTANCIATE_03()
    Set oTS = New CLS_TS
    '****************************************
    ' peut être passé comme ceci
    ' Call oTS.Instantiate("TBL_RAYON_1")
    ' par défaut c'est la feuille active
    '****************************************
    Call oTS.Instantiate(TBL_TS_03, FEUILLE_TS_03)
    MsgBox "OK INSTANCIATE_03"
    MsgBox "IsExistsQueryTable = " & oTS.IsExistsQueryTable
End Sub

Sub RefreshConnection()
Call INSTANCIATE_03
    Call oTS.RefreshConnection(False)
End Sub

Sub RefreshTable()
Call INSTANCIATE_03
    Call oTS.RefreshTable(False)
End Sub

Sub getTABLE()
Call INSTANCIATE_03
    Dim oObj As ListObject
    Set oObj = oTS.table
    MsgBox oObj.Name
End Sub
  
Sub getDATA()
Call INSTANCIATE_03
    Dim rData As Range
    Set rData = oTS.Data
    MsgBox rData.Count
End Sub

Sub getCommandText()
Call INSTANCIATE_03
    MsgBox oTS.CommandText
End Sub

Sub getConnectionName()
Call INSTANCIATE_03
    MsgBox oTS.ConnectionName
End Sub

Sub getQueryTableWorkbookConDescr()
Call INSTANCIATE_03
    MsgBox oTS.QueryTableWorkbookConnectDescr
End Sub

Sub getQueryTB()
Call INSTANCIATE_03
    Dim oQTB As QueryTable
    Set oQTB = oTS.QueryTB
    MsgBox oQTB.CommandText
End Sub

Sub getQueryConnection()
Call INSTANCIATE_03
    Dim oCnx As WorkbookConnection
    Set oCnx = oTS.QueryConnection
    MsgBox oCnx.Name
End Sub

Sub getQueryTableConnection()
Call INSTANCIATE_03
    MsgBox oTS.QueryTableConnection
End Sub

Sub INSTANCIATE_04()
    Set oTS = New CLS_TS
    '****************************************
    ' peut être passé comme ceci
    ' Call oTS.Instantiate("TBL_RAYON_1")
    ' par défaut c'est la feuille active
    '****************************************
    Call oTS.Instantiate(TBL_TS_04, FEUILLE_TS_04)
    MsgBox "OK INSTANCIATE_04"
    MsgBox "IsExistsQueryTable = " & oTS.IsExistsQueryTable
End Sub

Sub clearContentsRow()
Call INSTANCIATE_04
    Call oTS.clearContentsRow(5)
End Sub

Sub clearContentsColumnByIndex()
Call INSTANCIATE_04
    Call oTS.clearContentsColumnByIndex(7)
End Sub

Sub clearContentsColumnByName()
Call INSTANCIATE_04
    Call oTS.clearContentsColumnByName("RAYON_6")
End Sub

Sub clearContentsVisibleRow()
Call INSTANCIATE_04
    Call oTS.clearContentsVisibleRow
End Sub

Sub deleteVisibleRow()
Call INSTANCIATE_04
    Call oTS.deleteVisibleRow
End Sub

'*********************************************************************
'* Source du code : Patrick TOULON sur https://excel-downloads.com/
'* Ajout le       : 01/05/2025
'*********************************************************************
'* DEBUT
'*********************************************************************
Sub exportToXML_02()
Call INSTANCIATE_02
    Call oTS.exportToXML2(ThisWorkbook.Path & "\TestExportToXML_02.xml", True)
    MsgBox "Source Patrick TOULON - XLD - https://excel-downloads.com/"
End Sub

Sub exportToHTML()
Call INSTANCIATE_02
    Call oTS.exportToHTML(ThisWorkbook.Path & "\TestExportToHTML.HTML", True)
    MsgBox "Source Patrick TOULON - XLD - https://excel-downloads.com/"
End Sub

Sub exportToImageJPG_01()
Call INSTANCIATE_02
    Call oTS.exportToImagefile(ThisWorkbook.Path & "\TestExportToJPG.jpg", True, True)
    MsgBox "Source Patrick TOULON - XLD - https://excel-downloads.com/"
End Sub
'*********************************************************************
'* Source du code : Patrick TOULON sur https://excel-downloads.com/
'* Ajout le       : 01/05/2025
'*********************************************************************
'* FIN
'*********************************************************************
Sub exportToImagefile_02()
Call INSTANCIATE_02
    Call oTS.exportToImagefile_02(ThisWorkbook.Path & "\" & TBL_TS_02 & ".jpg", True, True)
End Sub

Sub exportToImagefile_03()
Call INSTANCIATE_03
    ' cette fois sans les titres de colonnes
    Call oTS.exportToImagefile_03(ThisWorkbook.Path & "\" & TBL_TS_03 & ".jpeg", True, False)
End Sub

Sub exportToImagefile_04()
Call INSTANCIATE_03
    ' cette fois sans les titres de colonnes
    Call oTS.exportToImagefile_03(ThisWorkbook.Path & "\" & TBL_TS_03 & ".jpg", True, True)
End Sub

Sub exportToPDF()
Call INSTANCIATE_02
    Call oTS.exportToPDF(ThisWorkbook.Path & "\" & TBL_TS_02 & ".pdf", True, True)
End Sub

Sub exportToPDF_01()
Call INSTANCIATE_02
    Call oTS.exportToPDF(ThisWorkbook.Path & "\" & TBL_TS_02 & ".pdf", True, True, True, xlLandscape, 100)
End Sub

Sub exportToPDF_02()
Call INSTANCIATE_02
    Call oTS.exportToPDF(ThisWorkbook.Path & "\" & TBL_TS_02 & ".pdf", True, True, True, xlPortrait, 80)
End Sub

Sub createTSFromCells()
Call INSTANCIATE_02
    Dim wk As Worksheet
    Set wk = ThisWorkbook.Worksheets("CREATE_TS")
    Call oTS.createTSFromCells(wk, "A2", "TS_TEST2")
End Sub

Sub createTSFromCells_02()
Call INSTANCIATE_02
    Dim wk As Worksheet
    Set wk = ThisWorkbook.Worksheets("CREATE_TS")
    Call oTS.createTSFromCells(wk, "A2", "TS_TEST2", , xlNo)
End Sub

Sub createTSFromCells_03()
Call INSTANCIATE_02
    Dim wk As Worksheet
    Set wk = ThisWorkbook.Worksheets("CREATE_TS")
    Call oTS.createTSFromCells(wk, "I1:O21", "TS_TEST3", , xlYes)
End Sub

Sub exportToExcel()
Call INSTANCIATE_02
    Call oTS.exportToExcel(ThisWorkbook.Path & "\" & TBL_TS_02 & ".xlsx")
End Sub

Sub exportToExcel_02()
Call INSTANCIATE_02
    Call oTS.exportToExcel(ThisWorkbook.Path & "\" & TBL_TS_02 & ".xlsx", True, True)
End Sub

patricktoulon · 2 Mai 2025

re
Attention certaine version d'excel sont un peu molle du clipboard (surtout les clik&run voir les cloud )garre !! à l'image blache!!

tu peut faire la même chose avec ta version
pour la 2

VB:

  'ActiveChart.Paste
 Do: DoEvents
        ActiveChart.Paste
    Loop While ActiveChart.Pictures.Count = 0

après je ne pense pas que ce soit nécessaire de toute les garder
la 03 est très bien
je ne suis pas sur qu'une fonction soit nécessaire pour l'extension un mid instrrev suffit
mais tu fait comme tu veux ,j'ai essayé de rester dans ta façon de coder

pour la 3(bien entendu avec le do/loop sur paste )encore une fois pour éviter l'image blanche

VB:

Sub exportToImagefile_03(hFileName As String, _
                         Optional hReplace As Integer = True, Optional hHeader As Boolean = False)

    Dim rRangeToPicture As Range
    Dim oChart As Chart
    Dim sExt As String

    Dim oTString As Cls_ToolsStrings
    Set oTString = New Cls_ToolsStrings
    sExt = Mid(hFileName, InStrRev(hFileName, ".") + 1)

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If

    ' Pour rester cohérent avec la version 01 proposée
    '--------------------------------------------------
    If hHeader Then
        Set rRangeToPicture = pRange ' on récupère tout le tableau avec un Range #All
    Else
        Set rRangeToPicture = pDataBody
    End If

    rRangeToPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Set oChart = ActiveSheet.ChartObjects.Add(rRangeToPicture.Left, _
                                              rRangeToPicture.Top, _
                                              rRangeToPicture.Width, _
                                              rRangeToPicture.Height).Chart

    With oChart
        .Parent.Activate
        .ChartArea.Format.Line.Visible = msoFalse
        Do While .Pictures.Count = 0
            DoEvents
            .Paste
        Loop
        .Export hFileName, sExt
        .Parent.Delete
    End With

End Sub

garde la 3 et jette les deux autres ( c'est pas la peine a mon avis de garder 3 fonctions qui font la même chose)
la xml je te laisse décider si tu veux rester en string ou en object xml
si un jour tu veux la sub de lecture xml et reconstitution listobject tu me le dit

oguruma · 3 Mai 2025

patricktoulon à dit:
re
Attention certaine version d'excel sont un peu molle du clipboard (surtout les clik&run voir les cloud )garre !! à l'image blache!!

tu peut faire la même chose avec ta version
pour la 2

VB:

'ActiveChart.Paste Do: DoEvents ActiveChart.Paste Loop While ActiveChart.Pictures.Count = 0

après je ne pense pas que ce soit nécessaire de toute les garder
la 03 est très bien
je ne suis pas sur qu'une fonction soit nécessaire pour l'extension un mid instrrev suffit
mais tu fait comme tu veux ,j'ai essayé de rester dans ta façon de coder

pour la 3(bien entendu avec le do/loop sur paste )encore une fois pour éviter l'image blanche

VB:

Sub exportToImagefile_03(hFileName As String, _ Optional hReplace As Integer = True, Optional hHeader As Boolean = False) Dim rRangeToPicture As Range Dim oChart As Chart Dim sExt As String Dim oTString As Cls_ToolsStrings Set oTString = New Cls_ToolsStrings sExt = Mid(hFileName, InStrRev(hFileName, ".") + 1) If pOTools.isFileExists(hFileName) Then If hReplace <> -1 Then Err.Raise _ ERROR_MESSAGE, _ ERROR_SOURCE, _ ERROR_MSG & " : Le fichier " & hFileName & " existe déjà" End If End If ' Pour rester cohérent avec la version 01 proposée '-------------------------------------------------- If hHeader Then Set rRangeToPicture = pRange ' on récupère tout le tableau avec un Range #All Else Set rRangeToPicture = pDataBody End If rRangeToPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap Set oChart = ActiveSheet.ChartObjects.Add(rRangeToPicture.Left, _ rRangeToPicture.Top, _ rRangeToPicture.Width, _ rRangeToPicture.Height).Chart With oChart .Parent.Activate .ChartArea.Format.Line.Visible = msoFalse Do While .Pictures.Count = 0 DoEvents .Paste Loop .Export hFileName, sExt .Parent.Delete End With End Sub

garde la 3 et jette les deux autres ( c'est pas la peine a mon avis de garder 3 fonctions qui font la même chose)
la xml je te laisse décider si tu veux rester en string ou en object xml
si un jour tu veux la sub de lecture xml et reconstitution listobject tu me le dit

Bonjour, je note de côté ta proposition. Merci.

oguruma · 3 Mai 2025

oguruma à dit:
Bonjour, je note de côté ta proposition. Merci.

Il est vrai que le DoEvents on y pense pas toujours....
bon du reste j'ai un bête de compett comme PC un i7 avec 12 Go de mémoire et 500 Go en mémoire flash... donc ça dépote et on ne sent pas la différence.... mais il est vrai qu'avec des pc un peu mou mou le DoEvents soulage le processeur
cette V03 que j'ai adapté pour l'occasion je l'avais développé chez un client pour générer des mails en html automatiques avec l'insertion de graphiques pour faire un flash info sur les traitement batch de nuit (mainframe IBM 3090 2500 Jobs chaque nuit en homolog et le double en production - COBOL Batch/DB2 - tu devines ? du traitement bancaire) et pour une fois il m'avait filé aussi une bête de course... (rare chez les clients) donc là aussi pas eu le besoin de mettre cette boucle....

patricktoulon · 3 Mai 2025

bon tu es assis là ?
entre temps j'avais travaillé sur la v1.01 et je t'ai fait un xml de ouff
bon d'accords je me suis un peu envolé là mais bon ca démontre bien la puissance que l'on a à travailler avec un object DOMdocument plutot que string
je me vois mal faire ça en string même si j'y arriverais
alors pour l'exemple
j'ai mis des couleurs dans le tableaux

voici le code

VB:

Sub exportToXML_03()
Call INSTANCIATE_02
    Call oTS.exportToXML3(ThisWorkbook.Path & "\TestExportToXMLV3.xml", True)
End Sub

et dans la classe

VB:

Sub exportToXML3(hFileName As String, Optional hReplace As Integer = True)
    'Auteur :patricktoulon
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim color1 As Long
    Dim color2 As Long
    Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
    Dim TableName, tableStyle, HeadCol, TableHeader, TableBody, properties, hasheader, ligne, cel, themecolor1, themecolor2, tss

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    Set tss = ThisWorkbook.TableStyles(pTable.tableStyle)

    color1 = tss.TableStyleElements(xlRowStripe1).Interior.Color
    color2 = tss.TableStyleElements(xlRowStripe2).Interior.Color
    If color2 = 0 Then color2 = vbWhite

    vHeaders = getHeaders()
    Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
    With XmlDoc
        Set ROOT = .appendchild(.createelement("table")) 'CREATION DE L'ELEMENT ROOT Tag(table)

        Set properties = ROOT.appendchild(.createelement("properties")) 'creation d'une balise propertiesqui contiendra les propreties que l'on veux

        'creation et intégration du post processing
        Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
        .InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing

        Set TableName = properties.appendchild(.createelement("Name")) 'balise table name contient le nom du listobject
        TableName.Text = CStr(pNameTS)

        Set tableStyle = properties.appendchild(.createelement("tablestyle")) 'balise tablestyle (contient le style du tableau
        tableStyle.Text = CStr(pTable.tableStyle)

        Set hasheader = properties.appendchild(.createelement("hasheader")) 'balise hasheader (contient 1 ou 0) selon si le tableau a un header ou pas
        hasheader.Text = Abs(pTable.ShowHeaders)

        Set themecolor1 = properties.appendchild(.createelement("themecolor1")) 'balise themecolor1 (contient la couleur 1 du style du tableau)
        themecolor1.Text = "&H" & Hex(color1)

        Set themecolor2 = properties.appendchild(.createelement("themecolor2")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        themecolor2.Text = "&H" & Hex(color2)


        If pTable.ShowHeaders Then ' si le tableau a un header
            Set TableHeader = ROOT.appendchild(.createelement("headers")) 'creation de la balise header
            'ajout des balises headcol correspontes au cellule du header du tableau
            For i = LBound(vHeaders) To UBound(vHeaders)
                Set HeadCol = TableHeader.appendchild(.createelement("headcol"))
                HeadCol.Text = vHeaders(i)
                HeadCol.setattribute "index", i + 1 'attribut index de colonne
                HeadCol.setattribute "Width", pDataBody.Cells(1, i + 1).Width 'attribut largeur de colonne
                HeadCol.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de cellule header
            Next
        End If

        Set TableBody = ROOT.appendchild(.createelement("tablebody"))

        For i = 1 To pDataBody.Rows.Count
            Set ligne = ROOT.appendchild(.createelement("row"))
            ligne.setattribute "index", i
            ligne.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de ligne

            For c = 1 To pDataBody.Columns.Count
                Set cel = ligne.appendchild(.createelement("cell"))
                cel.Text = pDataBody.Cells(i, c)
                cel.setattribute "bold", Abs(pDataBody.Cells(i, c).Font.Bold)
                cel.setattribute "FontName", pDataBody.Cells(i, c).Font.Name

                Dim expectedColor As Long
                expectedColor = IIf(i Mod 2 = 1, color1, color2)
                If pDataBody.Cells(i, c).DisplayFormat.Interior.Color <> expectedColor Then
                    cel.setattribute "interiorcolor", pDataBody.Cells(i, c).Interior.Color
                End If

            Next
        Next


        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText IndenterXMLCode(XmlDoc.XML)
        oStream.SaveToFile hFileName, 2
    End With
End Sub

le resultat dans le xml

XML:

<?xml version="1.0" encoding="UTF-8" ?>
<table>
    <properties>
        <Name>TBL_RAYON_DEMO_02</Name>
        <tablestyle>TableStyleMedium2</tablestyle>
        <hasheader>1</hasheader>
        <themecolor1>&amp;HF5F0D8</themecolor1>
        <themecolor2>&amp;HFFFFFF</themecolor2>
    </properties>
    <headers>
        <headcol index="1" Width="66" height="14.25">PRODUIT</headcol>
        <headcol index="2" Width="66" height="14.25">RAYON_1</headcol>
        <headcol index="3" Width="84.75" height="14.25">RAYON_2</headcol>
        <headcol index="4" Width="66" height="14.25">RAYON_3</headcol>
        <headcol index="5" Width="66" height="14.25">RAYON_4</headcol>
        <headcol index="6" Width="66" height="14.25">RAYON_5</headcol>
        <headcol index="7" Width="66" height="14.25">RAYON_6</headcol>
    </headers>
    <tablebody/>
    <row index="1" height="14.25">
        <cell bold="0" FontName="Arial">Prod_1</cell>
        <cell bold="0" FontName="Arial">684</cell>
        <cell bold="0" FontName="Arial">665</cell>
        <cell bold="0" FontName="Arial">361</cell>
        <cell bold="0" FontName="Arial">341</cell>
        <cell bold="0" FontName="Arial">578</cell>
        <cell bold="0" FontName="Arial">723</cell>
    </row>
    <row index="2" height="14.25">
        <cell bold="0" FontName="Arial">Prod_2</cell>
        <cell bold="0" FontName="Arial">194</cell>
        <cell bold="0" FontName="Arial" interiorcolor="65535">498</cell>
        <cell bold="0" FontName="Arial">979</cell>
        <cell bold="0" FontName="Arial">869</cell>
        <cell bold="0" FontName="Arial">609</cell>
        <cell bold="0" FontName="Arial">331</cell>
    </row>
    <row index="3" height="14.25">
        <cell bold="0" FontName="Arial">Prod_3</cell>
        <cell bold="0" FontName="Arial">792</cell>
        <cell bold="0" FontName="Arial">252</cell>
        <cell bold="0" FontName="Arial">293</cell>
        <cell bold="0" FontName="Arial">338</cell>
        <cell bold="0" FontName="Arial">334</cell>
        <cell bold="0" FontName="Arial">212</cell>
    </row>
    <row index="4" height="14.25">
        <cell bold="0" FontName="Arial">Prod_4</cell>
        <cell bold="0" FontName="Arial">366</cell>
        <cell bold="0" FontName="Arial">296</cell>
        <cell bold="0" FontName="Arial">912</cell>
        <cell bold="0" FontName="Arial">908</cell>
        <cell bold="0" FontName="Arial">999</cell>
        <cell bold="0" FontName="Arial">171</cell>
    </row>
    <row index="5" height="14.25">
        <cell bold="0" FontName="Arial">Prod_5</cell>
        <cell bold="0" FontName="Arial">326</cell>
        <cell bold="0" FontName="Arial">660</cell>
        <cell bold="0" FontName="Arial">192</cell>
        <cell bold="0" FontName="Arial">730</cell>
        <cell bold="0" FontName="Arial">403</cell>
        <cell bold="0" FontName="Arial">581</cell>
    </row>
    <row index="6" height="14.25">
        <cell bold="0" FontName="Arial">Prod_6</cell>
        <cell bold="0" FontName="Arial">715</cell>
        <cell bold="0" FontName="Arial">146</cell>
        <cell bold="0" FontName="Arial">939</cell>
        <cell bold="0" FontName="Arial">619</cell>
        <cell bold="0" FontName="Arial">755</cell>
        <cell bold="0" FontName="Arial">142</cell>
    </row>
    <row index="7" height="14.25">
        <cell bold="0" FontName="Arial">Prod_7</cell>
        <cell bold="0" FontName="Arial">774</cell>
        <cell bold="0" FontName="Arial">919</cell>
        <cell bold="0" FontName="Arial">127</cell>
        <cell bold="0" FontName="Arial">314</cell>
        <cell bold="0" FontName="Arial">579</cell>
        <cell bold="0" FontName="Arial">649</cell>
    </row>
    <row index="8" height="14.25">
        <cell bold="0" FontName="Arial">Prod_8</cell>
        <cell bold="0" FontName="Arial">414</cell>
        <cell bold="0" FontName="Arial">952</cell>
        <cell bold="0" FontName="Arial">671</cell>
        <cell bold="0" FontName="Arial">875</cell>
        <cell bold="0" FontName="Arial">595</cell>
        <cell bold="0" FontName="Arial">742</cell>
    </row>
    <row index="9" height="14.25">
        <cell bold="0" FontName="Arial">Prod_9</cell>
        <cell bold="0" FontName="Arial">363</cell>
        <cell bold="0" FontName="Arial">277</cell>
        <cell bold="0" FontName="Arial">895</cell>
        <cell bold="0" FontName="Arial">714</cell>
        <cell bold="0" FontName="Arial">703</cell>
        <cell bold="0" FontName="Arial">271</cell>
    </row>
    <row index="10" height="14.25">
        <cell bold="0" FontName="Arial">Prod_10</cell>
        <cell bold="0" FontName="Arial">888</cell>
        <cell bold="0" FontName="Arial">774</cell>
        <cell bold="0" FontName="Arial">903</cell>
        <cell bold="0" FontName="Arial">716</cell>
        <cell bold="0" FontName="Arial">346</cell>
        <cell bold="0" FontName="Arial">617</cell>
    </row>
</table>

ca depote hein 😉

oguruma · 3 Mai 2025

patricktoulon à dit:

bon tu es assis là ?
entre temps j'avais travaillé sur la v1.01 et je t'ai fait un xml de ouff
bon d'accords je me suis un peu envolé là mais bon ca démontre bien la puissance que l'on a à travailler avec un object DOMdocument plutot que string
je me vois mal faire ça en string même si j'y arriverais
alors pour l'exemple
j'ai mis des couleurs dans le tableaux
Regarde la pièce jointe 1217368
voici le code

VB:

Sub exportToXML_03()
Call INSTANCIATE_02
    Call oTS.exportToXML3(ThisWorkbook.Path & "\TestExportToXMLV3.xml", True)
End Sub

et dans la classe

VB:

Sub exportToXML3(hFileName As String, Optional hReplace As Integer = True)
    'Auteur :patricktoulon
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim color1 As Long
    Dim color2 As Long
    Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
    Dim TableName, tableStyle, HeadCol, TableHeader, TableBody, properties, hasheader, ligne, cel, themecolor1, themecolor2, tss

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    Set tss = ThisWorkbook.TableStyles(pTable.tableStyle)

    color1 = tss.TableStyleElements(xlRowStripe1).Interior.Color
    color2 = tss.TableStyleElements(xlRowStripe2).Interior.Color
    If color2 = 0 Then color2 = vbWhite

    vHeaders = getHeaders()
    Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
    With XmlDoc
        Set ROOT = .appendchild(.createelement("table")) 'CREATION DE L'ELEMENT ROOT Tag(table)

        Set properties = ROOT.appendchild(.createelement("properties")) 'creation d'une balise propertiesqui contiendra les propreties que l'on veux

        'creation et intégration du post processing
        Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
        .InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing

        Set TableName = properties.appendchild(.createelement("Name")) 'balise table name contient le nom du listobject
        TableName.Text = CStr(pNameTS)

        Set tableStyle = properties.appendchild(.createelement("tablestyle")) 'balise tablestyle (contient le style du tableau
        tableStyle.Text = CStr(pTable.tableStyle)

        Set hasheader = properties.appendchild(.createelement("hasheader")) 'balise hasheader (contient 1 ou 0) selon si le tableau a un header ou pas
        hasheader.Text = Abs(pTable.ShowHeaders)

        Set themecolor1 = properties.appendchild(.createelement("themecolor1")) 'balise themecolor1 (contient la couleur 1 du style du tableau)
        themecolor1.Text = "&H" & Hex(color1)

        Set themecolor2 = properties.appendchild(.createelement("themecolor2")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        themecolor2.Text = "&H" & Hex(color2)


        If pTable.ShowHeaders Then ' si le tableau a un header
            Set TableHeader = ROOT.appendchild(.createelement("headers")) 'creation de la balise header
            'ajout des balises headcol correspontes au cellule du header du tableau
            For i = LBound(vHeaders) To UBound(vHeaders)
                Set HeadCol = TableHeader.appendchild(.createelement("headcol"))
                HeadCol.Text = vHeaders(i)
                HeadCol.setattribute "index", i + 1 'attribut index de colonne
                HeadCol.setattribute "Width", pDataBody.Cells(1, i + 1).Width 'attribut largeur de colonne
                HeadCol.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de cellule header
            Next
        End If

        Set TableBody = ROOT.appendchild(.createelement("tablebody"))

        For i = 1 To pDataBody.Rows.Count
            Set ligne = ROOT.appendchild(.createelement("row"))
            ligne.setattribute "index", i
            ligne.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de ligne

            For c = 1 To pDataBody.Columns.Count
                Set cel = ligne.appendchild(.createelement("cell"))
                cel.Text = pDataBody.Cells(i, c)
                cel.setattribute "bold", Abs(pDataBody.Cells(i, c).Font.Bold)
                cel.setattribute "FontName", pDataBody.Cells(i, c).Font.Name

                Dim expectedColor As Long
                expectedColor = IIf(i Mod 2 = 1, color1, color2)
                If pDataBody.Cells(i, c).DisplayFormat.Interior.Color <> expectedColor Then
                    cel.setattribute "interiorcolor", pDataBody.Cells(i, c).Interior.Color
                End If

            Next
        Next


        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText IndenterXMLCode(XmlDoc.XML)
        oStream.SaveToFile hFileName, 2
    End With
End Sub

le resultat dans le xml

XML:

<?xml version="1.0" encoding="UTF-8" ?>
<table>
    <properties>
        <Name>TBL_RAYON_DEMO_02</Name>
        <tablestyle>TableStyleMedium2</tablestyle>
        <hasheader>1</hasheader>
        <themecolor1>&amp;HF5F0D8</themecolor1>
        <themecolor2>&amp;HFFFFFF</themecolor2>
    </properties>
    <headers>
        <headcol index="1" Width="66" height="14.25">PRODUIT</headcol>
        <headcol index="2" Width="66" height="14.25">RAYON_1</headcol>
        <headcol index="3" Width="84.75" height="14.25">RAYON_2</headcol>
        <headcol index="4" Width="66" height="14.25">RAYON_3</headcol>
        <headcol index="5" Width="66" height="14.25">RAYON_4</headcol>
        <headcol index="6" Width="66" height="14.25">RAYON_5</headcol>
        <headcol index="7" Width="66" height="14.25">RAYON_6</headcol>
    </headers>
    <tablebody/>
    <row index="1" height="14.25">
        <cell bold="0" FontName="Arial">Prod_1</cell>
        <cell bold="0" FontName="Arial">684</cell>
        <cell bold="0" FontName="Arial">665</cell>
        <cell bold="0" FontName="Arial">361</cell>
        <cell bold="0" FontName="Arial">341</cell>
        <cell bold="0" FontName="Arial">578</cell>
        <cell bold="0" FontName="Arial">723</cell>
    </row>
    <row index="2" height="14.25">
        <cell bold="0" FontName="Arial">Prod_2</cell>
        <cell bold="0" FontName="Arial">194</cell>
        <cell bold="0" FontName="Arial" interiorcolor="65535">498</cell>
        <cell bold="0" FontName="Arial">979</cell>
        <cell bold="0" FontName="Arial">869</cell>
        <cell bold="0" FontName="Arial">609</cell>
        <cell bold="0" FontName="Arial">331</cell>
    </row>
    <row index="3" height="14.25">
        <cell bold="0" FontName="Arial">Prod_3</cell>
        <cell bold="0" FontName="Arial">792</cell>
        <cell bold="0" FontName="Arial">252</cell>
        <cell bold="0" FontName="Arial">293</cell>
        <cell bold="0" FontName="Arial">338</cell>
        <cell bold="0" FontName="Arial">334</cell>
        <cell bold="0" FontName="Arial">212</cell>
    </row>
    <row index="4" height="14.25">
        <cell bold="0" FontName="Arial">Prod_4</cell>
        <cell bold="0" FontName="Arial">366</cell>
        <cell bold="0" FontName="Arial">296</cell>
        <cell bold="0" FontName="Arial">912</cell>
        <cell bold="0" FontName="Arial">908</cell>
        <cell bold="0" FontName="Arial">999</cell>
        <cell bold="0" FontName="Arial">171</cell>
    </row>
    <row index="5" height="14.25">
        <cell bold="0" FontName="Arial">Prod_5</cell>
        <cell bold="0" FontName="Arial">326</cell>
        <cell bold="0" FontName="Arial">660</cell>
        <cell bold="0" FontName="Arial">192</cell>
        <cell bold="0" FontName="Arial">730</cell>
        <cell bold="0" FontName="Arial">403</cell>
        <cell bold="0" FontName="Arial">581</cell>
    </row>
    <row index="6" height="14.25">
        <cell bold="0" FontName="Arial">Prod_6</cell>
        <cell bold="0" FontName="Arial">715</cell>
        <cell bold="0" FontName="Arial">146</cell>
        <cell bold="0" FontName="Arial">939</cell>
        <cell bold="0" FontName="Arial">619</cell>
        <cell bold="0" FontName="Arial">755</cell>
        <cell bold="0" FontName="Arial">142</cell>
    </row>
    <row index="7" height="14.25">
        <cell bold="0" FontName="Arial">Prod_7</cell>
        <cell bold="0" FontName="Arial">774</cell>
        <cell bold="0" FontName="Arial">919</cell>
        <cell bold="0" FontName="Arial">127</cell>
        <cell bold="0" FontName="Arial">314</cell>
        <cell bold="0" FontName="Arial">579</cell>
        <cell bold="0" FontName="Arial">649</cell>
    </row>
    <row index="8" height="14.25">
        <cell bold="0" FontName="Arial">Prod_8</cell>
        <cell bold="0" FontName="Arial">414</cell>
        <cell bold="0" FontName="Arial">952</cell>
        <cell bold="0" FontName="Arial">671</cell>
        <cell bold="0" FontName="Arial">875</cell>
        <cell bold="0" FontName="Arial">595</cell>
        <cell bold="0" FontName="Arial">742</cell>
    </row>
    <row index="9" height="14.25">
        <cell bold="0" FontName="Arial">Prod_9</cell>
        <cell bold="0" FontName="Arial">363</cell>
        <cell bold="0" FontName="Arial">277</cell>
        <cell bold="0" FontName="Arial">895</cell>
        <cell bold="0" FontName="Arial">714</cell>
        <cell bold="0" FontName="Arial">703</cell>
        <cell bold="0" FontName="Arial">271</cell>
    </row>
    <row index="10" height="14.25">
        <cell bold="0" FontName="Arial">Prod_10</cell>
        <cell bold="0" FontName="Arial">888</cell>
        <cell bold="0" FontName="Arial">774</cell>
        <cell bold="0" FontName="Arial">903</cell>
        <cell bold="0" FontName="Arial">716</cell>
        <cell bold="0" FontName="Arial">346</cell>
        <cell bold="0" FontName="Arial">617</cell>
    </row>
</table>

ca depote hein 😉

OK j'intègre tout ça pour une prochaine version de manière à avoir une version universelle

patricktoulon · 3 Mai 2025

attends je te la peaufine
j'essaie de lire les font de style de sheet et TS mais ton fichier semble avoir traversé une tempête
le style font name pa defaut dans les options excel est "police corp"
le thisworkbook.style(1).font.name donne "corbel"
et le ThisWorkbook.TableStyles(pTable.tableStyle).font.name donne NULL

pourtant tout est en "Arial" DANS TON FICHIER

c'est compliqué là 🤣 🤣 🤣 🤣 🤣 🤣

patricktoulon · 3 Mai 2025

bon j'ai trouvé une astuce
bon ben on est pas mal là
a la relecture du xml on pourrait facilement reproduire le TS ou simplement en range avec le même thème

VB:

Sub exportToXML3(hFileName As String, Optional hReplace As Integer = True)
    'Auteur :patricktoulon
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim color1 As Long
    Dim color2 As Long
    Dim Fnam
    Dim Fcolor
    Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
    Dim TableName, tableStyle, HeadCol, TableHeader, TableBody, properties, hasheader, ligne, cel, themecolor1, themecolor2, tss, fn, fc

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    Set tss = ThisWorkbook.TableStyles(pTable.tableStyle)

    color1 = tss.TableStyleElements(xlRowStripe1).Interior.Color
    color2 = tss.TableStyleElements(xlRowStripe2).Interior.Color
    If color2 = 0 Then color2 = vbWhite
    Fnam = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
    If IsNull(Fnam) Then Fnam = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Name

    Fcolor = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
    If IsNull(Fcolor) Then Fcolor = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Color

    vHeaders = getHeaders()
    Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
    With XmlDoc
        Set ROOT = .appendchild(.createelement("table")) 'CREATION DE L'ELEMENT ROOT Tag(table)

        Set properties = ROOT.appendchild(.createelement("properties")) 'creation d'une balise propertiesqui contiendra les propreties que l'on veux

        'creation et intégration du post processing
        Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
        .InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing

        Set TableName = properties.appendchild(.createelement("Name")) 'balise table name contient le nom du listobject
        TableName.Text = CStr(pNameTS)

        Set tableStyle = properties.appendchild(.createelement("tablestyle")) 'balise tablestyle (contient le style du tableau
        tableStyle.Text = CStr(pTable.tableStyle)

        Set hasheader = properties.appendchild(.createelement("hasheader")) 'balise hasheader (contient 1 ou 0) selon si le tableau a un header ou pas
        hasheader.Text = Abs(pTable.ShowHeaders)

        Set themecolor1 = properties.appendchild(.createelement("themecolor1")) 'balise themecolor1 (contient la couleur 1 du style du tableau)
        themecolor1.Text = color1

        Set themecolor2 = properties.appendchild(.createelement("themecolor2")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        themecolor2.Text = color2

        Set fn = properties.appendchild(.createelement("Font_name")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        fn.Text = Fnam

        Set fc = properties.appendchild(.createelement("Font_Color")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        fc.Text = Fcolor

        'ecriture du header
        If pTable.ShowHeaders Then ' si le tableau a un header
            Set TableHeader = ROOT.appendchild(.createelement("headers")) 'creation de la balise header
            'ajout des balises headcol correspontes au cellule du header du tableau
            For i = LBound(vHeaders) To UBound(vHeaders)
                Set HeadCol = TableHeader.appendchild(.createelement("headcol"))
                HeadCol.Text = vHeaders(i)
                HeadCol.setattribute "index", i + 1 'attribut index de colonne
                HeadCol.setattribute "Width", pDataBody.Cells(1, i + 1).Width 'attribut largeur de colonne
                HeadCol.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de cellule header
            Next
        End If

        'ecriture de la table(body)
        Set TableBody = ROOT.appendchild(.createelement("tablebody"))

        For i = 1 To pDataBody.Rows.Count
            Set ligne = ROOT.appendchild(.createelement("row"))
            ligne.setattribute "index", i
            ligne.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de ligne

            For c = 1 To pDataBody.Columns.Count
                Set cel = ligne.appendchild(.createelement("cell"))
                cel.Text = pDataBody.Cells(i, c)
                cel.setattribute "bold", Abs(pDataBody.Cells(i, c).Font.Bold)
                'on met les attributs Font(name et color) uniquement si elles sont différentes du général
                If pDataBody.Cells(i, c).Font.Name <> Fnam Then cel.setattribute "FontName", pDataBody.Cells(i, c).Font.Name
                If pDataBody.Cells(i, c).DisplayFormat.Font.Color <> Fcolor Then cel.setattribute "FontColor", pDataBody.Cells(i, c).DisplayFormat.Font.Color

                Dim expectedColor As Long
                expectedColor = IIf(i Mod 2 = 1, color1, color2)
                If pDataBody.Cells(i, c).DisplayFormat.Interior.Color <> expectedColor Then
                    cel.setattribute "interiorcolor", pDataBody.Cells(i, c).Interior.Color
                End If
            Next
        Next

        'écriture du fichier
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText IndenterXMLCode(XmlDoc.XML)
        oStream.SaveToFile hFileName, 2
    End With
End Sub

le résultat XML

XML:

<?xml version="1.0" encoding="UTF-8" ?>
<table>
    <properties>
        <Name>TBL_RAYON_DEMO_02</Name>
        <tablestyle>TableStyleMedium2</tablestyle>
        <hasheader>1</hasheader>
        <themecolor1>16117976</themecolor1>
        <themecolor2>16777215</themecolor2>
        <Font_name>Arial</Font_name>
        <Font_Color>0</Font_Color>
    </properties>
    <headers>
        <headcol index="1" Width="66" height="14.25">PRODUIT</headcol>
        <headcol index="2" Width="66" height="14.25">RAYON_1</headcol>
        <headcol index="3" Width="84.75" height="14.25">RAYON_2</headcol>
        <headcol index="4" Width="66" height="14.25">RAYON_3</headcol>
        <headcol index="5" Width="66" height="14.25">RAYON_4</headcol>
        <headcol index="6" Width="66" height="14.25">RAYON_5</headcol>
        <headcol index="7" Width="66" height="14.25">RAYON_6</headcol>
    </headers>
    <tablebody/>
    <row index="1" height="14.25">
        <cell bold="1" FontName="Arial Rounded MT Bold">Prod_1</cell>
        <cell bold="0">684</cell>
        <cell bold="0">665</cell>
        <cell bold="0">361</cell>
        <cell bold="0">341</cell>
        <cell bold="0">578</cell>
        <cell bold="0">723</cell>
    </row>
    <row index="2" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_2</cell>
        <cell bold="0">194</cell>
        <cell bold="0" interiorcolor="65535">498</cell>
        <cell bold="0" FontColor="7898643">979</cell>
        <cell bold="0" interiorcolor="5296274">869</cell>
        <cell bold="0">609</cell>
        <cell bold="0">331</cell>
    </row>
    <row index="3" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_3</cell>
        <cell bold="0">792</cell>
        <cell bold="0">252</cell>
        <cell bold="0">293</cell>
        <cell bold="0">338</cell>
        <cell bold="0">334</cell>
        <cell bold="0">212</cell>
    </row>
    <row index="4" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_4</cell>
        <cell bold="0">366</cell>
        <cell bold="0">296</cell>
        <cell bold="0">912</cell>
        <cell bold="0">908</cell>
        <cell bold="0">999</cell>
        <cell bold="0">171</cell>
    </row>
    <row index="5" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_5</cell>
        <cell bold="0">326</cell>
        <cell bold="0" FontColor="255">660</cell>
        <cell bold="0">192</cell>
        <cell bold="0">730</cell>
        <cell bold="0">403</cell>
        <cell bold="0">581</cell>
    </row>
    <row index="6" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_6</cell>
        <cell bold="0" interiorcolor="6724095">715</cell>
        <cell bold="0">146</cell>
        <cell bold="0">939</cell>
        <cell bold="0">619</cell>
        <cell bold="0">755</cell>
        <cell bold="0">142</cell>
    </row>
    <row index="7" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_7</cell>
        <cell bold="0">774</cell>
        <cell bold="0">919</cell>
        <cell bold="0" FontColor="16777215" interiorcolor="9408399">127</cell>
        <cell bold="0" FontColor="414899">314</cell>
        <cell bold="0">579</cell>
        <cell bold="0">649</cell>
    </row>
    <row index="8" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_8</cell>
        <cell bold="0">414</cell>
        <cell bold="0" FontColor="7898643">952</cell>
        <cell bold="0">671</cell>
        <cell bold="0">875</cell>
        <cell bold="0">595</cell>
        <cell bold="0">742</cell>
    </row>
    <row index="9" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_9</cell>
        <cell bold="0">363</cell>
        <cell bold="0">277</cell>
        <cell bold="0">895</cell>
        <cell bold="0">714</cell>
        <cell bold="0">703</cell>
        <cell bold="0">271</cell>
    </row>
    <row index="10" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_10</cell>
        <cell bold="0">888</cell>
        <cell bold="0">774</cell>
        <cell bold="0">903</cell>
        <cell bold="0">716</cell>
        <cell bold="0">346</cell>
        <cell bold="0">617</cell>
    </row>
</table>

c'é bo!! non?

oguruma · 3 Mai 2025

patricktoulon à dit:

bon j'ai trouvé une astuce
bon ben on est pas mal là
a la relecture du xml on pourrait facilement reproduire le TS ou simplement en range avec le même thème

VB:

Sub exportToXML3(hFileName As String, Optional hReplace As Integer = True)
    'Auteur :patricktoulon
    Dim vHeaders As Variant
    Dim i As Long
    Dim c As Long
    Dim color1 As Long
    Dim color2 As Long
    Dim Fnam
    Dim Fcolor
    Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
    Dim TableName, tableStyle, HeadCol, TableHeader, TableBody, properties, hasheader, ligne, cel, themecolor1, themecolor2, tss, fn, fc

    If pOTools.isFileExists(hFileName) Then
        If hReplace <> -1 Then
            Err.Raise _
      ERROR_MESSAGE, _
      ERROR_SOURCE, _
      ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
        End If
    End If
    Close
    Set tss = ThisWorkbook.TableStyles(pTable.tableStyle)

    color1 = tss.TableStyleElements(xlRowStripe1).Interior.Color
    color2 = tss.TableStyleElements(xlRowStripe2).Interior.Color
    If color2 = 0 Then color2 = vbWhite
    Fnam = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
    If IsNull(Fnam) Then Fnam = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Name

    Fcolor = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
    If IsNull(Fcolor) Then Fcolor = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Color

    vHeaders = getHeaders()
    Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
    With XmlDoc
        Set ROOT = .appendchild(.createelement("table")) 'CREATION DE L'ELEMENT ROOT Tag(table)

        Set properties = ROOT.appendchild(.createelement("properties")) 'creation d'une balise propertiesqui contiendra les propreties que l'on veux

        'creation et intégration du post processing
        Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
        .InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing

        Set TableName = properties.appendchild(.createelement("Name")) 'balise table name contient le nom du listobject
        TableName.Text = CStr(pNameTS)

        Set tableStyle = properties.appendchild(.createelement("tablestyle")) 'balise tablestyle (contient le style du tableau
        tableStyle.Text = CStr(pTable.tableStyle)

        Set hasheader = properties.appendchild(.createelement("hasheader")) 'balise hasheader (contient 1 ou 0) selon si le tableau a un header ou pas
        hasheader.Text = Abs(pTable.ShowHeaders)

        Set themecolor1 = properties.appendchild(.createelement("themecolor1")) 'balise themecolor1 (contient la couleur 1 du style du tableau)
        themecolor1.Text = color1

        Set themecolor2 = properties.appendchild(.createelement("themecolor2")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        themecolor2.Text = color2

        Set fn = properties.appendchild(.createelement("Font_name")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        fn.Text = Fnam

        Set fc = properties.appendchild(.createelement("Font_Color")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
        fc.Text = Fcolor

        'ecriture du header
        If pTable.ShowHeaders Then ' si le tableau a un header
            Set TableHeader = ROOT.appendchild(.createelement("headers")) 'creation de la balise header
            'ajout des balises headcol correspontes au cellule du header du tableau
            For i = LBound(vHeaders) To UBound(vHeaders)
                Set HeadCol = TableHeader.appendchild(.createelement("headcol"))
                HeadCol.Text = vHeaders(i)
                HeadCol.setattribute "index", i + 1 'attribut index de colonne
                HeadCol.setattribute "Width", pDataBody.Cells(1, i + 1).Width 'attribut largeur de colonne
                HeadCol.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de cellule header
            Next
        End If

        'ecriture de la table(body)
        Set TableBody = ROOT.appendchild(.createelement("tablebody"))

        For i = 1 To pDataBody.Rows.Count
            Set ligne = ROOT.appendchild(.createelement("row"))
            ligne.setattribute "index", i
            ligne.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de ligne

            For c = 1 To pDataBody.Columns.Count
                Set cel = ligne.appendchild(.createelement("cell"))
                cel.Text = pDataBody.Cells(i, c)
                cel.setattribute "bold", Abs(pDataBody.Cells(i, c).Font.Bold)
                'on met les attributs Font(name et color) uniquement si elles sont différentes du général
                If pDataBody.Cells(i, c).Font.Name <> Fnam Then cel.setattribute "FontName", pDataBody.Cells(i, c).Font.Name
                If pDataBody.Cells(i, c).DisplayFormat.Font.Color <> Fcolor Then cel.setattribute "FontColor", pDataBody.Cells(i, c).DisplayFormat.Font.Color

                Dim expectedColor As Long
                expectedColor = IIf(i Mod 2 = 1, color1, color2)
                If pDataBody.Cells(i, c).DisplayFormat.Interior.Color <> expectedColor Then
                    cel.setattribute "interiorcolor", pDataBody.Cells(i, c).Interior.Color
                End If
            Next
        Next

        'écriture du fichier
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Charset = "utf-8"
        oStream.Open
        oStream.WriteText IndenterXMLCode(XmlDoc.XML)
        oStream.SaveToFile hFileName, 2
    End With
End Sub

Regarde la pièce jointe 1217369

le résultat XML

XML:

<?xml version="1.0" encoding="UTF-8" ?>
<table>
    <properties>
        <Name>TBL_RAYON_DEMO_02</Name>
        <tablestyle>TableStyleMedium2</tablestyle>
        <hasheader>1</hasheader>
        <themecolor1>16117976</themecolor1>
        <themecolor2>16777215</themecolor2>
        <Font_name>Arial</Font_name>
        <Font_Color>0</Font_Color>
    </properties>
    <headers>
        <headcol index="1" Width="66" height="14.25">PRODUIT</headcol>
        <headcol index="2" Width="66" height="14.25">RAYON_1</headcol>
        <headcol index="3" Width="84.75" height="14.25">RAYON_2</headcol>
        <headcol index="4" Width="66" height="14.25">RAYON_3</headcol>
        <headcol index="5" Width="66" height="14.25">RAYON_4</headcol>
        <headcol index="6" Width="66" height="14.25">RAYON_5</headcol>
        <headcol index="7" Width="66" height="14.25">RAYON_6</headcol>
    </headers>
    <tablebody/>
    <row index="1" height="14.25">
        <cell bold="1" FontName="Arial Rounded MT Bold">Prod_1</cell>
        <cell bold="0">684</cell>
        <cell bold="0">665</cell>
        <cell bold="0">361</cell>
        <cell bold="0">341</cell>
        <cell bold="0">578</cell>
        <cell bold="0">723</cell>
    </row>
    <row index="2" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_2</cell>
        <cell bold="0">194</cell>
        <cell bold="0" interiorcolor="65535">498</cell>
        <cell bold="0" FontColor="7898643">979</cell>
        <cell bold="0" interiorcolor="5296274">869</cell>
        <cell bold="0">609</cell>
        <cell bold="0">331</cell>
    </row>
    <row index="3" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_3</cell>
        <cell bold="0">792</cell>
        <cell bold="0">252</cell>
        <cell bold="0">293</cell>
        <cell bold="0">338</cell>
        <cell bold="0">334</cell>
        <cell bold="0">212</cell>
    </row>
    <row index="4" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_4</cell>
        <cell bold="0">366</cell>
        <cell bold="0">296</cell>
        <cell bold="0">912</cell>
        <cell bold="0">908</cell>
        <cell bold="0">999</cell>
        <cell bold="0">171</cell>
    </row>
    <row index="5" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_5</cell>
        <cell bold="0">326</cell>
        <cell bold="0" FontColor="255">660</cell>
        <cell bold="0">192</cell>
        <cell bold="0">730</cell>
        <cell bold="0">403</cell>
        <cell bold="0">581</cell>
    </row>
    <row index="6" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_6</cell>
        <cell bold="0" interiorcolor="6724095">715</cell>
        <cell bold="0">146</cell>
        <cell bold="0">939</cell>
        <cell bold="0">619</cell>
        <cell bold="0">755</cell>
        <cell bold="0">142</cell>
    </row>
    <row index="7" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_7</cell>
        <cell bold="0">774</cell>
        <cell bold="0">919</cell>
        <cell bold="0" FontColor="16777215" interiorcolor="9408399">127</cell>
        <cell bold="0" FontColor="414899">314</cell>
        <cell bold="0">579</cell>
        <cell bold="0">649</cell>
    </row>
    <row index="8" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_8</cell>
        <cell bold="0">414</cell>
        <cell bold="0" FontColor="7898643">952</cell>
        <cell bold="0">671</cell>
        <cell bold="0">875</cell>
        <cell bold="0">595</cell>
        <cell bold="0">742</cell>
    </row>
    <row index="9" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_9</cell>
        <cell bold="0">363</cell>
        <cell bold="0">277</cell>
        <cell bold="0">895</cell>
        <cell bold="0">714</cell>
        <cell bold="0">703</cell>
        <cell bold="0">271</cell>
    </row>
    <row index="10" height="14.25">
        <cell bold="0" FontName="Arial Rounded MT Bold">Prod_10</cell>
        <cell bold="0">888</cell>
        <cell bold="0">774</cell>
        <cell bold="0">903</cell>
        <cell bold="0">716</cell>
        <cell bold="0">346</cell>
        <cell bold="0">617</cell>
    </row>
</table>

c'é bo!! non?

ok top je package tout ça merci 🙂

oguruma · 5 Mai 2025

patricktoulon à dit:
attends je te la peaufine
j'essaie de lire les font de style de sheet et TS mais ton fichier semble avoir traversé une tempête
le style font name pa defaut dans les options excel est "police corp"
le thisworkbook.style(1).font.name donne "corbel"
et le ThisWorkbook.TableStyles(pTable.tableStyle).font.name donne NULL

pourtant tout est en "Arial" DANS TON FICHIER

c'est compliqué là 🤣 🤣 🤣 🤣 🤣 🤣

J'ai eu des soucis avec ma version O365... il y a quelques temps... j'ai même dû m'y reprendre à deux fois pour la réinstaller
exemple dans la boîte à outils du UserForm j'avais perdu les icônes... j'ai dû les remettre....
Dans le passé j'étais en mode Insider.... ça m'a cause d'énormes problèmes... fichiers corrompus etc. etc.
j'ai viré tout ce bazard, fait les réinstall...et depuis ça va bcp mieux... mais je suis certain qu'il en reste encore des traces
pourtant j'ai supprimé Office avec leur outil "le scrub..." spécifique et non avec le gestionnaire de programmes dans le panneau de config
je ne vais pas faire un "format c: à l'ancienne" pour avoir réinstall d'un office tout propre... 🙂
Donc probable qu'il y ait eu une tempête... mais dans le Nord la pluie ça ne nous fait pas peur 😀

oguruma · 5 Mai 2025

Nouvelle version 1.06 ICI

Effectuez une recherche sur Excel Downloads...

EXCEL :: Les Tableaux Structurés :: Une classe VBA - V1.05 - Evolutions majeures exports CSV, XML, XML UTF-8, JSON, HTML, PDF, JPG, JPEG, BMP, EXCEL

oguruma

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

oguruma

XLDnaute Impliqué

oguruma

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

oguruma

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

oguruma

XLDnaute Impliqué

oguruma

XLDnaute Impliqué

oguruma

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée