- 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
Created
October 5, 2018 22:30
-
-
Save Mandorlo/29e7addefec4a66b06dc7578bedb334d to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
' /!\ 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment