1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
| Option Explicit
Function getPartialArray(Lo As ListObject, Columns) As Variant
'Transfert de certaines colonnes de tableau structuré vers variable tableau
'https://www.developpez.net/forums/d2091033/logiciels/microsoft-office/excel/transfert-certaines-colonnes-tableau-structure-vers-variable-tableau/#post11618243
Dim temp, R As Long, C As Long
If Lo.ListRows.Count > 0 Then
temp = Lo.DataBodyRange.Value
ReDim T(1 To UBound(temp), 1 To UBound(Columns) + 1)
For R = 1 To UBound(temp)
For C = 0 To UBound(Columns)
T(R, C + 1) = temp(R, Lo.ListColumns(Columns(C)).index)
Next C
Next R
getPartialArray = T
End If
End Function
Function getListObject(Name As String, Optional Wbk As Workbook) As ListObject
'Fonction qui retourne un Objet "ListObject" en fonction de son nom, dans toutes les feuilles du classeur.
'Nothing si non trouvé
Dim Wsh As Worksheet, lCounter As Long
If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
For Each Wsh In Wbk.Worksheets
lCounter = 1
Do While lCounter <= Wsh.ListObjects.Count And getListObject Is Nothing
If Wsh.ListObjects(lCounter).Name = Name Then Set getListObject = Wsh.ListObjects(lCounter)
lCounter = lCounter + 1
Loop
Next Wsh
End Function
Function EditRow(Lo As ListObject, R As Long, Columns, Datas) As Boolean
'Fonction qui modifie les données de certaines colonnes (ou de toutes) d'une ligne
Dim C As Long
If R <= getLastRow(Lo) And R > 0 Then
If Lo.ListRows.Count = 0 Then Lo.ListRows.Add
For C = LBound(Columns) To UBound(Columns)
Lo.ListColumns(Columns(C)).DataBodyRange.Rows(R).Value = Datas(C)
Next
EditRow = True
End If
End Function
Function DeleteRow(Lo As ListObject, R As Long) As Boolean
'Supprime la ligne R, si possible
If Lo.ListRows.Count > 0 Then
If R < getLastRow(Lo) And R > 0 Then
Lo.ListRows(R).Delete
DeleteRow = True
End If
End If
End Function
Function InsertRow(Lo As ListObject, R As Long, Columns, Datas) As ListRow
'Insère une ligne et en complète les colonnes
Dim L As ListRow, C As Long
If R <= getLastRow(Lo) And R > 0 Then
Set L = Lo.ListRows.Add(R)
For C = LBound(Columns) To UBound(Columns)
Lo.ListColumns(Columns(C)).DataBodyRange.Rows(R).Value = Datas(C)
Next
Set InsertRow = L
End If
End Function
Function InsertColumn(Lo As ListObject, Optional ColumnName As String, Optional position As Integer) As ListColumn
'Insère une colonne nommée ColumnName, à l'endroit position. Si omis, à droite du tableau
Dim L As ListColumn
If position = 0 Then
Set L = Lo.ListColumns.Add
Else
Set L = Lo.ListColumns.Add(position:=Abs(position))
End If
If ColumnName <> vbNullString Then L.Name = ColumnName
Set InsertColumn = L
End Function
Function DeleteColumn(Lo As ListObject, ColumnName As String) As Boolean
'Supprime la colonne ColumnName, si possible
Dim Rng As Range
Set Rng = Lo.HeaderRowRange.Find(ColumnName)
If Not Rng Is Nothing Then
Lo.ListColumns(ColumnName).Delete
DeleteColumn = True
End If
End Function
Function getLastRow(Lo As ListObject) As Long
'Première "ligne vide"
getLastRow = 1
If Lo.ListRows.Count > 0 Then getLastRow = getLastRow + Lo.ListRows.Count
End Function
Function FindRow(Lo As ListObject, What As Variant, ColumnName As String) As Long
'Retourne le numéro de la ligne ou l'on trouve la valeur What dans la colonne ColumnName
'0 (zéro) si non trouvé
Dim Rng As Range, rngResult As Range
If Lo.ListRows.Count > 0 Then
Set Rng = Lo.HeaderRowRange.Find(ColumnName)
If Not Rng Is Nothing Then
Set rngResult = Lo.ListColumns(ColumnName).DataBodyRange.Find(What)
If Not rngResult Is Nothing Then FindRow = rngResult.Row - Lo.HeaderRowRange.Row
End If
End If
End Function |
