Dim LO As ListObject
Private Sub UserForm_Initialize()
Ini_LVw
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
If MsgBox("Revenir à ordre initial ? (après le dernier enregistrement)", vbYesNo) = vbYes Then CBn_RàZ_Click
End If
End Sub
Sub Ini_LVw()
Dim Echelle As Double, Tb, NbCol As Integer, Frmts(), LoBdDRg1 As Range, Header, i As Long, j As Integer
'Facteur d'échelle pour la largeur des colonnes
Echelle = 1
'ListObject
Set LO = [t_BDD].ListObject
'Nom des colonnes dans un tableau
Header = LO.HeaderRowRange
'Stockage des valeurs dans un tableau
Tb = [t_BDD].Value2
'Nbre de colonne du ListObject
NbCol = UBound(Tb, 2)
'Tableau pour stocker les formats
ReDim Frmts(1 To NbCol)
'Première ligne de données du ListObject
Set LoBdDRg1 = [t_BDD].Rows(1)
With Me.LVw_tb
'Création des entêtes, alignement à droite des dates et des doubles, mémorisation des formats de la 1ère ligne.
With .ColumnHeaders
.Clear
.Add , , "idx", 0
For i = 1 To NbCol
.Add , , Header(1, i), [t_BDD].ListObject.ListColumns(i).Range.Width * Echelle
If VarType(LoBdDRg1.Cells(i).Value) = vbDouble Or VarType(LoBdDRg1.Cells(i).Value) = vbDate Then .Item(i + 1).Alignment = lvwColumnRight
Frmts(i) = Replace(Replace(Replace(Replace(Replace(LoBdDRg1.Cells(i).NumberFormatLocal, "jj", "dd"), "aaaa", "yyyy"), "Standard", "General"), ",", "."), """", """""")
Next
End With
'Aspect de la Listview
.View = lvwReport
.Gridlines = True
.AllowColumnReorder = False
.FullRowSelect = True
.LabelEdit = lvwManual
For i = 1 To UBound(Tb)
'Créations des Items (utilisés comme index) avec une clef type "K00000001" et un Texte type "00000001"
.ListItems.Add , Format(i, """K""00000000"), Format(i, "00000000")
With .ListItems(i)
'Création des SubItems, avec un format pour les valeurs numériques
For j = 1 To UBound(Tb, 2)
.ListSubItems.Add , , IIf(IsNumeric(Tb(i, j)), Evaluate("=Text(" & Replace(Tb(i, j), ",", ".") & ",""" & Frmts(j) & """)"), Tb(i, j))
Next j
End With
Next i
.HideSelection = False
'Désélectionner la première ligne
.ListItems(1).Selected = False
Set .SelectedItem = Nothing
End With
End Sub
Private Sub CBn_RàZ_Click()
'Remettre dans le même ordre que lors de l'affichage du formulaire ou du dernier enregistrement
Dim Tb(), i As Long
With Me.LVw_tb
nbLgn = .ListItems.Count
.Sorted = False
ReDim Tb(1 To nbLgn, 1 To 1)
For i = 1 To nbLgn
'(mémorisation des clefs dans l'ordre actuel)
Tb(i, 1) = .ListItems(i).Key
'Replacer les index (texte des ListItems) par les clefs
.ListItems(i).Text = .ListItems(i).Key
Next
'Tri sur les clefs
.SortKey = 0
.Sorted = True
.Sorted = False
For i = 1 To nbLgn
'Actualiser les index
.ListItems(i).Text = Format(i, "00000000")
Next
.SetFocus
.SelectedItem.EnsureVisible
End With
With LO
'Remettre dans l'ordre initial le ListObject
'Ajout d'une colonne contenant les clefs
.ListColumns.Add
.ListColumns(.ListColumns.Count).DataBodyRange.Value = Tb
'Tri ascendant sur la colonne ajoutée
With .Sort
.SortFields.Clear
.SortFields.Add Key:=LO.ListColumns(LO.ListColumns.Count).Range, SortOn:=xlSortOnValues, Order:=xlAscending
.Header = xlYes
.Apply
End With
'Suppression de la colonne ajoutée
.ListColumns(.ListColumns.Count).Delete
End With
End Sub
Private Sub CBn_Enregistrer_Click()
'Enregistrer l'ordre actuel de la listview
If MsgBox("Sauvegarder l'ordre actuel du tableau ?", vbYesNo) = vbYes Then
Me.LVw_tb.ListItems.Clear
Ini_LVw
End If
End Sub
Private Sub SBn_Déplacer_SpinUp()
'Déplacement vers le haut
Dim N° As Long, Tb, rang As String, i As Long
N° = Me.LVw_tb.SelectedItem.Index
'bidouille pour conserver le rehaussement en bleu de la ligne sélectionnée
Me.LVw_tb.SetFocus
Me.SBn_Déplacer.SetFocus
Me.LVw_tb.SetFocus
Application.ScreenUpdating = False
Tb = LO.ListRows(N°).Range.Formula2R1C1Local
With Me.LVw_tb
If N° > 1 Then
'Déplacement vers le haut (diminution de l'index)
.Sorted = False
rang = .SelectedItem.Text
.SelectedItem.Text = Format(CLng(rang) - 1, "00000000")
.ListItems(N° - 1).Text = rang
LO.ListRows.Add (N° - 1)
LO.ListRows(N° - 1).Range.Formula2R1C1Local = Tb
LO.ListRows(N° + 1).Delete
Else
'Déplacement en fin de liste
.Sorted = False
.SelectedItem.Text = Format(.ListItems.Count, "00000000")
For i = 2 To .ListItems.Count
.ListItems(i).Text = Format(i - 1, "00000000")
Next
LO.ListRows.Add
LO.ListRows(LO.ListRows.Count).Range.Formula2R1C1Local = Tb
LO.ListRows(1).Delete
End If
'Tri avec les nouveaux index
.SortKey = 0
.SortOrder = lvwAscending
.Sorted = True
.Sorted = False
.SelectedItem.EnsureVisible
.Refresh
End With
Application.ScreenUpdating = True
End Sub
Private Sub SBn_Déplacer_SpinDown()
'Déplacement vers le bas
Dim N° As Long, Tb, rang As String, i As Long
N° = Me.LVw_tb.SelectedItem.Index
'bidouille pour conserver le rehaussement en bleu de la ligne sélectionnée
Me.LVw_tb.SetFocus
Me.SBn_Déplacer.SetFocus
Me.LVw_tb.SetFocus
Application.ScreenUpdating = False
Tb = LO.ListRows(N°).Range.Formula2R1C1Local
With Me.LVw_tb
If N° < .ListItems.Count Then
'Déplacement vers le bas
.Sorted = False
rang = .SelectedItem.Text
.SelectedItem.Text = Format(CLng(rang) + 1, "00000000")
.ListItems(N° + 1).Text = rang
LO.ListRows.Add (N° + 2)
LO.ListRows(N° + 2).Range.Formula2R1C1Local = Tb
LO.ListRows(N°).Delete
Else
'Déplacement en tête de liste
.Sorted = False
.SelectedItem.Text = "00000001"
For i = 1 To .ListItems.Count - 1
.ListItems(i).Text = Format(i, "00000000")
Next i
LO.ListRows.Add 1
LO.ListRows(1).Range.Formula2R1C1Local = Tb
LO.ListRows(LO.ListRows.Count).Delete
End If
'Tri avec les nouveaux index
.SortKey = 0
.SortOrder = lvwAscending
.Sorted = True
.Sorted = False
.SelectedItem.EnsureVisible
.Refresh
End With
Application.ScreenUpdating = True
End Sub
www.excel-downloads.com
