EXCEL :: Les Tableaux Structurés :: Une classe VBA pour mieux les gérer - V1.02

oguruma · 26 Avril 2025

Bonjour Le Forum,
ce post fait suite à celui ici.
Il apporte de nouvelles fonctionnalités.
Elle reprend bien entendu les fonctionnalités des versions précédentes.
Certes nous pouvons aller encore plus loin mais l'essentiel des besoins y est.
Voici les onglets de tests.

Le code pour les tests est dans le module : MOD_TEST_CLASS
Le code de la classe : CLS_TS

LE CODE POUR LES TEST

Code:

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

LA CLASSE

VB:

Option Explicit

'**************************************************************************
'*  Classe CLS_TS sur les tableaux structurés
'**************************************************************************
'* Auteur    : OGURUMA
'* Date      : 21/04/2025
'* Version   : Initiale
'*
'***************************************************************************
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§_§")
    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
    If Not pOTools.exitsTS(hTB) Then
        Err.Raise _
            ERROR_MESSAGE, _
            ERROR_SOURCE, _
            ERROR_MSG & " : Le tableau " & hTB & " est inconnu"
    End If
    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]")
    pTblHeaders = pHeaders.Cells
    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
End Property

Property Get Address() As String
    Address = pAddressData
End Property

Property Get Headers() As Variant
    Headers = pTblHeaders
End Property

' Début V1.01
Property Get NameWk() As String
    NameWk = pWkName
End Property

Property Get HeaderAddress() As String
    HeaderAddress = pHeaderAddress
End Property

Property Get HeaderRow() As Long
    HeaderRow = pHeaderRow
End Property

Property Get HeaderColumn() As Long
    HeaderColumn = pHeaderColumn
End Property

Property Get DataRow() As Long
    DataRow = pDataRow
End Property

Property Get DataColumn() As Long
    DataColumn = pDataColumn
End Property

' Fin V1.01

' Début V1.02
Property Get Table() As ListObject
    Set Table = pTable
End Property

Property Get Data() As Range
    Set Data = pDataBody
End Property

Property Get IsExistsQueryTable() As Boolean
    IsExistsQueryTable = pIsExistsQueryTable
End Property

Property Get CommandText() As String
    CommandText = pQueryTableCommandText
End Property

Property Get ConnectionName() As String
    ConnectionName = pQueryTableWorkbookConnectName
End Property
 
Property Get QueryTableWorkbookConnectDescr() As String
    QueryTableWorkbookConnectDescr = pQueryTableWorkbookConnectDescr
End Property

Property Get QueryTB() As QueryTable
    Set QueryTB = pQueryTable
End Property

Property Get QueryConnection() As WorkbookConnection
   Set QueryConnection = pQueryTableWorkbookConnection
End Property

Property Get QueryTableConnection()
    QueryTableConnection = pQueryTableConnection
End Property

' Fin V1.02

Function getNbrows() As Long
    pNbRows = pDataBody.Rows.Count
    getNbrows = pDataBody.Rows.Count
End Function

Function getTableNbrows() As Long
    pTableNbRows = pDataBody.Rows.Count
    getTableNbrows = pTable.ListRows.Count
End Function

Function getNbColumns() As Integer
    pNbColumns = pDataBody.Columns.Count
    getNbColumns = pDataBody.Columns.Count
End Function

Function getHeaderToString(Optional hSep = ";") As String
    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
    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
    pNbRows = pDataBody.Rows.Count
    pNbColumns = pDataBody.Columns.Count
    getDataBodyCount = pDataBody.Count
End Function

Function getDataBodyCellsCount() As Long
    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
    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
    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
    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
    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

oguruma · 5 Mai 2025

Nouvelle version ICI

bsalv · 5 Mai 2025

Bonjour oguruma,
n'est-ce pas trop compliqué pour par exemple, le cas le plus simple, ajouter une seule ligne ?
Moi je fais ceci (maintenant en 2 subs, mais normallement dans une seule)

VB:

Sub Ajouter_Ligne()
     Dim Arr, Ligne As Long, LO As ListObject

     Set LO = Range("TBL_RAYON_3").ListObject     'la feuille n'a pas d'importance dans un module normal
     Arr = Array("PROD_NEW", 100, 200, 300, 400, 500, 600)     'données à ajouter
     Ligne = 500

     Ajouter_au_LO LO, Arr, Ligne            'ajouter ces valeurs au LO
End Sub

Sub Ajouter_au_LO(LO As ListObject, Arr, Optional Ligne As Long)
     Dim c
     With LO
          If .ListRows.Count = 0 Then        'LO est vide
               Set c = .InsertRowRange
          Else
               If Ligne = 0 Then Ligne = .ListRows.Count + 1     '0 = au bout
               Ligne = Application.Min(Ligne, .ListRows.Count + 1)     'si trop élevé = après dernière ligne
               Set c = .ListRows.Add(Ligne).Range
          End If
          c.Resize(, UBound(Arr) + 1).Value = Arr
     End With
End Sub

oguruma · 5 Mai 2025

bsalv à dit:

Bonjour oguruma,
n'est-ce pas trop compliqué pour par exemple, le cas le plus simple, ajouter une seule ligne ?
Moi je fais ceci (maintenant en 2 subs, mais normallement dans une seule)

VB:

Sub Ajouter_Ligne()
     Dim Arr, Ligne As Long, LO As ListObject

     Set LO = Range("TBL_RAYON_3").ListObject     'la feuille n'a pas d'importance dans un module normal
     Arr = Array("PROD_NEW", 100, 200, 300, 400, 500, 600)     'données à ajouter
     Ligne = 500

     Ajouter_au_LO LO, Arr, Ligne            'ajouter ces valeurs au LO
End Sub

Sub Ajouter_au_LO(LO As ListObject, Arr, Optional Ligne As Long)
     Dim c
     With LO
          If .ListRows.Count = 0 Then        'LO est vide
               Set c = .InsertRowRange
          Else
               If Ligne = 0 Then Ligne = .ListRows.Count + 1     '0 = au bout
               Ligne = Application.Min(Ligne, .ListRows.Count + 1)     'si trop élevé = après dernière ligne
               Set c = .ListRows.Add(Ligne).Range
          End If
          c.Resize(, UBound(Arr) + 1).Value = Arr
     End With
End Sub

bjr à toi de l'embarquer dans tes propres évolutions - pour le reste ça fonctionne
on ne va pas refaire l'histoire !!!
c'est livré en l'état. !
CQFD !
si je passe mon temps à faire la revue de code de outils livrés... j'en ai jusqu'à la fin de mes jours !
déjà un dim c ça ne veut rien dire et de plus non typé !
alors je continue ou pas ?

bsalv · 5 Mai 2025

moi je le fais comme ceci en quelque lignes
PS. je ne déclare (presque) jamais mais variables

VB:

Sub Simple()

     Set LO = Range("TBL_RAYON_3").ListObject     'la feuille n'a pas d'importance dans un module normal
 
     '......
      Arr = Array("PROD_NEW", 100, 200, 300, 400, 500, 600)     'données à ajouter
     LO.ListRows.Add.Range.Resize.Resize(, UBound(Arr) + 1).Value = Arr 'au bout
     LO.ListRows.Add(5).Range.Resize.Resize(, UBound(Arr) + 1).Value = Arr 'à une ligne spécifique
     '..............

End Sub

Effectuez une recherche sur Excel Downloads...

EXCEL :: Les Tableaux Structurés :: Une classe VBA pour mieux les gérer - V1.02

oguruma

XLDnaute Impliqué

Pièces jointes

oguruma

XLDnaute Impliqué

bsalv

XLDnaute Occasionnel

oguruma

XLDnaute Impliqué

bsalv

XLDnaute Occasionnel

Discussions similaires

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