DOC_LIB_EXCEL.md

Documentation LIB_EXCEL

Liste des fonctions

• syncRemoteMatrices : synchronise des tableaux entre 2 classeurs ou 2 onglets
• myCBool : comme CBool mais CBool("") = false
• getOpt : fonction pour gérer les options dans les arguments de fonctions
• rechercheLigne
• rechercheV
• rechercheRange
• IndexEquiv
• getColLetter : renvoie la lettre de la colonne d'une cellule
• sommePlage
• rangeExists
• sheetExists
• formExists
• formHasText
• formHasTextRange
• zorder_put : place la forme sh au ZOrder z
• clearTab : supprime le contenu d'un tableau sans affecter les formules
• hasComment : dit si la cellule a un commentaire ou non

LIB_EXCEL.vbs

' /!\ fonction incomplète
' dépend de rangeExists, myCBool, getOpt, IndexEquiv, IsInColl
' synchronise 2 matrices distantes (matrice = tableau où les lignes et les colonnes sont nommées
' opt : (par ex : "clear:true;clearColumns:c1|c2|c3;createCol:true")
' - id:[nom] (nom = le nom de la colonne qui contient les ID des lignes) (défaut = première colonne)
' - clear:(true|FALSE)
' - clearColumns:column1|column2|column3
' - createAll:(true|FALSE)
' - createRows:(true|FALSE)
' - createCols:(true|FALSE)
Sub syncRemoteMatrices(ByVal ws_src As Worksheet, ByVal tab_src As String, ByVal ws_dst As Worksheet, ByVal tab_dst As String, Optional ByVal opt As String = "")
    ' on vérifie que les tableaux existent
    If Not rangeExists(ws_src, tab_src) Or Not rangeExists(ws_dst, tab_dst) Then
        Debug.Print "syncoteTabs : table names do not exist !"
        Exit Sub
    End If
    
    ' optim perf deb
    old_su = Application.ScreenUpdating
    old_cm = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' paramètres des logs
    Dim log_count_updated_cells As Integer
    ' collection des row/col à ajouter/supprimer
    Dim list_row_add As New Collection
    Dim list_col_add As New Collection
    ' on récupère le nom de la colonne d'ID
    id_col_name = getOpt("id", opt)
    If id_col_name = "" Then id_col_name = Replace(ws_src.Range(tab_src).Columns(1).Rows(0).Value, "'", "''")
    ' on récupère les options
    b_createColIfNotExists = myCBool(getOpt("createCols", opt)) Or myCBool(getOpt("createAll", opt))
    b_createRowIfNotExists = myCBool(getOpt("createRows", opt)) Or myCBool(getOpt("createAll", opt))
    b_clearBeforeImport = myCBool(getOpt("clear", opt))
    clearBeforeImportColumnNames = "|" & getOpt("clearColumns", opt) & "|"
    
    ' on nettoie le tableau de destination si besoin
    If b_clearBeforeImport Or Len(clearBeforeImportColumnNames) > 2 Then
        For i = 1 To ws_dst.Range(tab_dst).Columns.Count
            If ws_dst.Range(tab_dst).Columns(i).Rows(1).Formula = "" And ws_dst.Range(tab_dst).Columns(i).Rows(0).Value <> id_col_name _
                And (Len(clearBeforeImportColumnNames) <= 2 Or InStr(clearBeforeImportColumnNames, "|" & ws_dst.Range(tab_dst).Columns(i).Rows(0).Value & "|") > 0) Then
                ws_dst.Range(tab_dst).Columns(i).ClearContents
            End If
        Next i
    End If
    
    ' pour chaque colonne du tableau source
    For j = 1 To ws_src.Range(tab_src).Columns.Count
        curr_col = ws_src.Range(tab_src).Columns(j).Rows(0).Value
        ' si le nom de cette colonne existe dans le tableau dest
        If rangeExists(ws_dst, tab_dst & "[" & curr_col & "]") Then
            ' alors pour chaque ligne du tableau source,
            For i = 1 To ws_src.Range(tab_src).Rows.Count
                curr_row = ws_src.Range(tab_src & "[" & id_col_name & "]").Rows(i).Value
                Set r = IndexEquiv(ws_dst.Range(tab_dst & "[" & id_col_name & "]"), ws_dst.Range(tab_dst & "[" & curr_col & "]"), curr_row)
                ' si le nom de cette ligne existe dans le tableau dest
                If Not r Is Nothing Then
                    ' on colle la valeur du tableau source dans le tableau dest
                    If Not r.HasFormula And r.Value <> ws_src.Range(tab_src).Rows(i).Columns(j).Value Then
                        r.Value = ws_src.Range(tab_src).Rows(i).Columns(j).Value
                        log_count_updated_cells = log_count_updated_cells + 1
                    End If
                ' si le nom de cette ligne n'existe pas et qu'on a mis l'option createAll ou createRow, on se prépare à l'ajouter
                ElseIf b_createRowIfNotExists And Not isInColl(list_row_add, i) Then
                    list_row_add.Add i
                End If
            Next i
        ElseIf b_createColIfNotExists And Not isInColl(list_col_add, i) Then
            list_col_add.Add i
        End If
    Next j
    
    ' ajout des intitulés des colonnes à ajouter
    ' TODO
    ' ajout des intitulés des lignes à ajouter
    For Each num_lig In list_row_add
        ws_dst.Range(tab_dst).ListObject.ListRows.Add (num_lig)
        ws_dst.Range(tab_dst & "[" & id_col_name & "]").Rows(num_lig).Value = ws_src.Range(tab_src & "[" & id_col_name & "]").Rows(num_lig).Value
        For Each nom_col In ws_dst.Range(tab_dst).Rows(0).Columns
            nom_col2 = Replace(nom_col, "'", "''")
            If Not ws_dst.Range(tab_dst & "[" & nom_col2 & "]").Rows(num_lig).HasFormula Then
                ws_dst.Range(tab_dst & "[" & nom_col2 & "]").Rows(num_lig).Value = ws_src.Range(tab_src & "[" & nom_col2 & "]").Rows(num_lig).Value
            Else
                ws_dst.Range(tab_dst & "[" & nom_col2 & "]").Rows(num_lig).Formula = ws_src.Range(tab_src & "[" & nom_col2 & "]").Rows(num_lig).Formula
            End If
        Next nom_col
    Next num_lig
    
    ' fin optim perf
    Application.ScreenUpdating = old_cu
    Application.Calculation = old_cm
End Sub

' comme CBool mais en plus CBool("") = false
Function myCBool(ByVal s As String) As Boolean
    If s = "" Then
        myCBool = False
    Else
        myCBool = CBool(s)
    End If
End Function

' dans une chaine d'options opt (de type [nom_opt1]:[val_opt1];[nom_opt2]:[val_opt2];...)
' renvoie la valeur de l'option nom_opt
Function getOpt(ByVal nom_opt As String, ByVal opt As String) As String
    getOpt = ""
    arr = Split(opt, nom_opt & ":")
    If UBound(arr) > 0 Then
        getOpt = Split(arr(1), ";")(0)
    End If
End Function

' renvoie le numéro de la première ligne où la val est trouvée dans plage
' on peut spécifier une fonction en paramètre pour des fonctions de comparaison spécifiques
Function rechercheLigne(ByVal val As String, ByVal plage As Range, Optional ByVal fonction As String = "") As Integer
    rechercheLigne = -1
    Dim b As Boolean
    For i = 1 To plage.Rows.Count
        If fonction = "" Then
            b = (plage.Rows(i).Value = val)
        Else
            b = CallByName(Application, fonction, VbMethod, plage.Rows(i).Value, val)
        End If
        If b Then
            rechercheLigne = plage.Rows(i).Row
            Exit Function
        End If
    Next i
End Function

' wrapper de la fonction vlookup, qui ne fait pas planter vba et qui est plus ergonomique
Function rechercheV(ByVal needle As String, ByVal ws As Worksheet, ByVal nom_tab As String, ByVal col_dep As String, Optional ByVal col_fin As String = "##") As String
    On Error Resume Next
    If col_fin = "##" Then col_fin = col_dep
    num_col = ws.Range(nom_tab & "[" & col_fin & "]").Column - ws.Range(nom_tab & "[" & col_dep & "]").Column + 1
    rechercheV = Application.WorksheetFunction.VLookup(needle, ws.Range(nom_tab & "[[" & col_dep & "]:[" & col_fin & "]]"), num_col, False)
End Function

' cherche la valeur needle dans plage_input et renvoie la cellule correspondante dans plage_output
' attention, plage_input et plage_output doivent avoir les mêmes dimensions !
' ind (optionnel) permet de renvoyer le ind-ième résultat au lieu du premier par défaut
Function rechercheRange(ByVal plage_input As Range, ByVal plage_output As Range, ByVal needle As String, Optional ByVal ind As Integer = 1, Optional ByVal fonction As String = "") As Range
    Set rechercheRange = Nothing
    If plage_input.Rows.Count <> plage_output.Rows.Count Or plage_input.Columns.Count <> plage_input.Columns.Count Then Exit Function
    nbligne = plage_input.Rows.Count
    nbcolonne = plage_input.Columns.Count
    
    For i = 1 To plage_input.Rows.Count
        For j = 1 To plage_input.Columns.Count
            If fonction = "" Then
                b = (plage_input.Rows(i).Columns(j).Value = needle)
            Else
                'b = CallByName(Application, fonction, VbMethod, plage_input.Rows(i).Columns(j).Value, needle)
                b = Application.Run(fonction, Array(plage_input.Rows(i).Columns(j).Value, needle))
            End If
            If b Then
                If ind <= 1 Then
                    Set rechercheRange = plage_output.Rows(i).Columns(j)
                Else
                    Set new_plage_input = plage_input.Worksheet.Range(plage_input.Cells(minInt(i + 1, nbligne), minInt(j + 1, nbcolonne)), plage_input.Cells(nbligne, nbcolonne))
                    Set new_plage_output = plage_output.Worksheet.Range(plage_output.Cells(minInt(i + 1, nbligne), minInt(j + 1, nbcolonne)), plage_output.Cells(nbligne, nbcolonne))
                    Set rechercheRange = rechercheRange(new_plage_input, new_plage_output, needle, ind - 1)
                End If
                Exit Function
            End If
        Next j
    Next i
End Function

' ressemble à la fonction rechercheRange mais plus rapide sans possibilité de fonction auxiliaire
Function IndexEquiv(ByVal plage_input As Range, ByVal plage_output As Range, ByVal needle As String, Optional ByVal ind As Integer = 1) As Range
    On Error GoTo fin
    i = 0
    nbrows = plage_input.Rows.Count
    Set IndexEquiv = Nothing
    
    While ind > 0
        tmp_i = Application.WorksheetFunction.Match(needle, plage_input, 0)
        i = i + tmp_i
        adresse = plage_input.Cells(tmp_i + 1, 1).Address & ":" & plage_input.Cells(nbrows, 1).Address
        If tmp_i < nbrows Then Set plage_input = plage_input.Worksheet.Range(adresse)
        ind = ind - 1
    Wend

    If i > 0 And i <= plage_output.Rows.Count Then
        Set IndexEquiv = plage_output.Rows(i)
    End If
fin:
End Function

' renvoie la lettre de la colonne de la cellule r
Function getColLetter(ByVal r As Range)
    tmpp = Split(r.Address, "$")
    getColLetter = tmpp(1)
End Function

' dit si le nom s de la feuille ws existe
Function rangeExists(ByVal ws As Worksheet, ByVal s As String) As Boolean
    On Error GoTo erreurrangeexists
    Set re = ws.Range(s)
    rangeExists = True
    Exit Function
erreurrangeexists:
    rangeExists = False
End Function

' dit si la feuille nom_feuille du workbook wb existe
Function sheetExists(ByVal wb As Workbook, ByVal nom_feuille As String) As Boolean
    On Error GoTo erreursheetexists
    Set ws = wb.Sheets(nom_feuille)
    sheetExists = True
    Exit Function
erreursheetexists:
    sheetExists = False
End Function

' indique si la forme portant le nom nom_forme existe dans la feuille ws
Function formExists(ByVal ws As Worksheet, ByVal nom_forme As String) As Boolean
    On Error GoTo formexistserror
    formExists = False
    Set sh = ws.Shapes(nom_forme)
    formExists = True
    Exit Function
formexistserror:
End Function

' indique si la forme contient du texte
Function formHasText(ByVal sh As Shape) As Boolean
    On Error GoTo formhastexterror
    formHasText = False
    If Not sh.TextFrame Is Nothing Then
        formHasText = (Len(sh.TextFrame.Characters.Text) > 0)
    End If
    Exit Function
formhastexterror:
End Function

' indique si la forme a une zone de texte oùon peut taper du texte
Function formHasTextRange(ByVal sh As Shape) As Boolean
    On Error GoTo errortextrange
    formHasTextRange = True
    t = sh.TextFrame2.TextRange.Text
    Exit Function
errortextrange:
    formHasTextRange = False
End Function

' place la forme sh au ZOrder z
Sub zorder_put(sh As Shape, ByVal z As Integer)
    compteur = 0
    While sh.ZOrderPosition > z And compteur < 300
        sh.ZOrder msoSendBackward
        compteur = compteur + 1
    Wend
End Sub

' supprime le contenu d'un tableau (sans affecter les formules qu'il y a dedans)
Sub clearTab(ByVal ws As Worksheet, ByVal nom_tab As String)
    ' on demarre l'optimisation de perfs
    old_ca = Application.Calculation
    old_su = Application.ScreenUpdating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    If Not ws.ListObjects(nom_tab).DataBodyRange Is Nothing Then
        If ws.Range(nom_tab).Rows.Count > 1 Then
            ws.ListObjects(nom_tab).DataBodyRange.Offset(1, 0).Resize(ws.ListObjects(nom_tab).DataBodyRange.Rows.Count - 1, _
                ws.ListObjects(nom_tab).DataBodyRange.Columns.Count).Rows.Delete
        End If
        On Error Resume Next
        ws.ListObjects(nom_tab).DataBodyRange.Rows(1).SpecialCells(xlCellTypeConstants).ClearContents
        ws.Range(nom_tab).ClearComments
    End If
    
    ' on termine l'optimisation de perfs
    Application.Calculation = old_ca
    Application.ScreenUpdating = old_su
End Sub

' effectue la somme des valeurs d'une plage
Function sommePlage(ByVal r As Range) As Double
    sommePlage = 0
    b = True
    If r.Rows.Count > 2000 Or r.Columns.Count > 2000 Then
        rep = MsgBox("Je vais effectuer la somme d'une plage avec " & r.Rows.Count & " lignes et " & r.Columns.Count & " colonnes. Voulez-vous continuer ?", vbYesNo)
        If rep = vbNo Then b = False
    End If
    If b Then
        For i = 1 To r.Rows.Count
            For j = 1 To r.Columns.Count
                sommePlage = sommePlage + r.Rows(i).Columns(j).Value
            Next j
        Next i
    End If
End Function

Function hasComment(ByVal r As Range) As Boolean
    ' tells if there is a comment in cell r
    Dim varComment As String
    Dim c As Comment
    On Error Resume Next
    Set c = r.Comment
    On Error GoTo 0
    If c Is Nothing Then
        hasComment = False
    Else
        hasComment = True
    End If
End Function