Exemple userform (modification de plusieurs colonnes en même temps)

Le 26/05/2024 à 19:56

Bonsoir,

J'ai vu pas mal d'exemples sur internet sur le forum. En faite, je travaille sur un projet et je veux avoir un exemple de Userform avec 6 colonnes ou plus.

Colonne 1 : compte client.

Au niveau de l'Userform, il y a une listbox avec propriété fmMultiSelectExtended filtrée par le critère Colonne 1. Chaque compte contient plusieurs données. Suite au filtre colonne 1, il y a plusieurs données affichées que je souhaite qu'elles soient modifiées en même temps via un Userform modification et suppression.

Voici le code VBA de l'userform

Option Compare Text
Dim f, NomTableau, TabBD(), ColCombo(), colVisu(), colInterro(), NcolVisu, NbCol, NcolInt, choix()

Private Sub ComboCommentaires_Click()
TextBox11.Value = ComboCommentaires.Column(0)
End Sub
Private Sub ComboEtat_Click()
TextBox18.Value = ComboEtat.Column(0)
End Sub

Private Sub ComboProchaineAction_Click()
TextBox14.Value = ComboProchaineAction.Column(0)
End Sub

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub CommandButton10_Click()
Dim MySym As Double
MySum = 0
With ListBox1
For r = 0 To .ListCount - 1
MySum = MySum + .List(r, 7)

Next r
End With

TxtSumColumn.Value = MySum
cmdTotal.Caption = val(TxtSumColumn.Text)
End Sub

Private Sub CommandButton3_Click()
For i = 1 To 6: Me("combobox" & i) = "*": Next i
End Sub

Private Sub ListBox1_Change()
Call NbreItems
End Sub

Private Sub ListCommentaires_Click()
TextBox11.Value = ListCommentaires.Column(0)
End Sub

Private Sub ListProchAction_Click()
TextBox14.Value = ListProchAction.Column(0)
End Sub
Private Sub TextBox41_Change()

End Sub

Private Sub ListStatus_Click()
TextBox18.Value = ListStatus.Column(0)
End Sub

Private Sub TxtSumColumn_Change()

End Sub

Private Sub UserForm_Initialize()

Call MacroFiltre
Call NbreItems
Set f = Sheets("bd")
Set Rng = f.Range("A2:U" & f.[a65000].End(xlUp).Row) ' à adapter
NomTableau = "Tableau1"
ActiveWorkbook.Names.Add Name:=NomTableau, RefersTo:=Rng ' A adapter
NbCol = Range(NomTableau).Columns.Count
'---- A adapter
TabBD = Range(NomTableau).Resize(, NbCol + 1).Value ' Array: + rapide
For i = 1 To UBound(TabBD): TabBD(i, NbCol + 1) = i: Next i ' No enregistrement
ColCombo = Array(4, 6, 10, 18, 13, 15) ' A adapter (1 à 6 colonnes maxi)
colVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21) ' Colonnes ListBox (à adapter)
colInterro = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21) ' colonnes à interroger (adapter)
'----
NcolInt = UBound(colInterro) + 1
Me.ListBox1.List = TabBD
For i = UBound(ColCombo) + 1 To 5
Me("combobox" & i + 1).Visible = False: Me("labelCbx" & i + 1).Visible = False
Next i
For c = 1 To UBound(ColCombo) + 1: Me("combobox" & c) = "*": Next c
For c = 1 To UBound(ColCombo) + 1: ListeCol c: Next c
For i = 1 To UBound(ColCombo) + 1: Me("labelCbx" & i) = Range(NomTableau).Offset(-1).Item(1, ColCombo(i - 1)): Next i
Me.ListBox1.ColumnCount = NbCol + 1
'-- en têtes de colonnes ListBox
'EnteteListBox ' Supprimer sur Excel 2013
'-- labels textbox

For i = NbCol + 1 To 40: Me("textbox" & i).Visible = False: Next i
For i = NbCol + 1 To 40: Me("label" & i).Visible = False: Next i
'-- colTri
Me.ComboTri.List = Application.Transpose(Range(NomTableau).Offset(-1).Resize(1)) ' Ordre tri
Affiche
B_ajout_Click


'ComboEtat.ListIndex = -1
'ComboEtat.Text = "Etat Dossier"

End Sub
Sub EnteteListBox()
x = Me.ListBox1.Left + 8
Y = Me.ListBox1.Top - 20
For c = 1 To NbCol
pos = Application.Match(c, colVisu, 0)
If Not IsError(pos) Then
k = c
Set Lab = Me.Controls.Add("Forms.Label.1")
Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
Lab.Top = Y
Lab.Left = x
Lab.Height = 24
Lab.Width = Range(NomTableau).Columns(c).Width * 1#
x = x + Range(NomTableau).Columns(c).Width * 1
tempcol = tempcol & Range(NomTableau).Columns(c).Width * 1# & ";"
Else
x = x + 0
tempcol = tempcol & 0 & ";"
End If
Next c
tempcol = tempcol & "20"
On Error Resume Next
Me.ListBox1.ColumnWidths = tempcol
On Error GoTo 0
End Sub

Sub ListeCol(noCol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare
For i = 1 To UBound(TabBD)
ok = True
For Cb = 0 To UBound(ColCombo)
colBD = ColCombo(Cb)
If Cb + 1 <> noCol Then
If Not TabBD(i, colBD) Like Me("comboBox" & Cb + 1) Then ok = False
End If
Next Cb
If ok Then
tmp = TabBD(i, ColCombo(noCol - 1))
d(tmp) = ""
End If
Next i
d("*") = ""
temp = d.keys
Tri temp, LBound(temp), UBound(temp)

Me("ComboBox" & noCol).List = temp
End Sub
Private Sub B_tout_Click()
For i = 1 To 6: Me("combobox" & i) = "*": Next i
End Sub
Private Sub ListBox1_Click()
For i = 1 To NbCol
tmp = Me.ListBox1.Column(i - 1)
If Not IsError(tmp) Then Me("textbox" & i) = tmp
Next i
Me.Enreg = Me.ListBox1.Column(NbCol)


End Sub
Sub Affiche()
Dim Tbl()
cbx1 = Me.ComboBox1: cbx2 = Me.ComboBox2: cbx3 = Me.ComboBox3: cbx4 = Me.ComboBox4: cbx5 = Me.ComboBox5: cbx6 = Me.ComboBox6
n = 0
Cb = Array(1, 1, 1, 1, 1, 1)
For i = 0 To UBound(ColCombo): Cb(i) = ColCombo(i): Next i
For i = 1 To UBound(TabBD)
If TabBD(i, Cb(0)) Like cbx1 And TabBD(i, Cb(1)) Like cbx2 _
And TabBD(i, Cb(2)) Like cbx3 And TabBD(i, Cb(3)) Like cbx4 And TabBD(i, Cb(4)) Like cbx5 And TabBD(i, Cb(5)) Like cbx6 Then
n = n + 1: ReDim Preserve Tbl(1 To NbCol + 1, 1 To n)
c = 0
For c = 1 To NbCol: Tbl(c, n) = TabBD(i, c): Next c
'Tbl(6, n) = Format(TabBD(i, 6), "hh:mm")
Tbl(c, n) = TabBD(i, NbCol + 1)
End If
Next i
If n > 0 Then
Me.ListBox1.Column = Tbl
Else
Me.ListBox1.Clear
End If
Gchoix
Call NbreItems

End Sub
Private Sub ComboBox1_DropButtonClick()
ListeCol 1
End Sub
Private Sub ComboBox2_DropButtonClick()
ListeCol 2
End Sub
Private Sub ComboBox3_DropButtonClick()
ListeCol 3
End Sub
Private Sub ComboBox4_DropButtonClick()
ListeCol 4
End Sub
Private Sub ComboBox5_DropButtonClick()
ListeCol 5
End Sub
Private Sub ComboBox6_DropButtonClick()
ListeCol 6
End Sub
Private Sub ComboBox1_Change()
Affiche
End Sub
Private Sub ComboBox2_Change()
Affiche
End Sub
Private Sub ComboBox3_Change()
Affiche
End Sub
Private Sub ComboBox4_Change()
Affiche
End Sub
Private Sub ComboBox5_Change()
Affiche
End Sub
Private Sub ComboBox6_Change()
Affiche
End Sub
Private Sub B_recup_Click()
Set f2 = Sheets("résultat")
f2.Cells.ClearContents
a = Me.ListBox1.List
f2.[A2].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
c = 0
For c = 1 To NbCol
f2.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c)
Next
f2.Cells.EntireColumn.AutoFit
End Sub
Private Sub B_valid_Click()
Enreg = Me.Enreg
For c = 1 To NbCol
If Not Range(NomTableau).Item(Enreg, c).HasFormula Then
tmp = Me("textbox" & c)
If IsNumeric(Replace(tmp, ".", ",")) And InStr(tmp, " ") = 0 Then
tmp = Replace(tmp, ".", ",")
Range(NomTableau).Item(Enreg, c) = CDbl(tmp)
Else
If IsDate(tmp) Then
Range(NomTableau).Item(Enreg, c) = CDate(tmp)
Else
Range(NomTableau).Item(Enreg, c) = tmp
End If
End If
Else
Range(NomTableau).Item(Enreg - 1, c).Copy
Range(NomTableau).Item(Enreg, c).PasteSpecial Paste:=xlPasteFormats
End If
Next c
UserForm_Initialize
raz
End Sub
Private Sub B_ajout_Click()
raz
Me.Enreg = Range(NomTableau).Rows.Count + 1
'Me.TextBox1.SetFocus
End Sub
Private Sub B_sup_Click()
If Me.Enreg <> "" Then
If MsgBox("Etes vous sûr de suppimer " & Me.TextBox1 & "?", vbYesNo) = vbYes Then
[Tableau1].Rows(Me.Enreg).Delete
Me.Enreg = ""
UserForm_Initialize
raz
Me.Enreg = Range(NomTableau).Rows.Count + 1
End If
End If
End Sub
Sub raz()
For k = 1 To NbCol
Me("textBox" & k) = ""
Next k
Me.TextBox1.SetFocus
End Sub
Private Sub B_duplique_Click()
Me.Enreg = Range(NomTableau).Rows.Count + 1
saisie_numéro_facture
saisie_montant_facture
B_valid_Click
End Sub
Sub Tri(a, gauc, droi) ' Quick sort
ref = CStr(a((gauc + droi) \ 2))
g = gauc: d = droi
Do
Do While CStr(a(g)) < ref: g = g + 1: Loop
Do While ref < CStr(a(d)): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub
Private Sub ComboMenu_click()
nomcontrole = Me.TextBoxActive
Me(nomcontrole) = Me.ComboMenu.Value
Me.ComboMenu.Visible = False
End Sub
Private Sub ComboTri_click()
Dim Tbl()
colTri = Me.ComboTri.ListIndex
Tbl = Me.ListBox1.List
TriMultiCol Tbl, LBound(Tbl), UBound(Tbl), colTri
Me.ListBox1.List = Tbl

End Sub
Sub TriMultiCol(a(), gauc, droi, colTri) ' Quick sort
Dim colD, colF, ref, g, d, c, temp
colD = LBound(a, 2): colF = UBound(a, 2)
ref = a((gauc + droi) \ 2, colTri)
g = gauc: d = droi
Do
Do While a(g, colTri) < ref: g = g + 1: Loop
Do While ref < a(d, colTri): d = d - 1: Loop
If g <= d Then
For c = colD To colF
temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
Next
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then TriMultiCol a, g, droi, colTri
If gauc < d Then TriMultiCol a, gauc, d, colTri
End Sub
Sub Gchoix()
'-- génération de choix()
BDListBox = Me.ListBox1.List
ReDim choix(1 To UBound(BDListBox) + 1)
col = UBound(BDListBox, 2)
For i = LBound(BDListBox) To UBound(BDListBox)
For Each k In colInterro
choix(i + 1) = choix(i + 1) & BDListBox(i, k - 1) & "|"
Next k
choix(i + 1) = choix(i + 1) & BDListBox(i, col) & "|" ' no enreg
Next i
Me.TextBoxRech = ""
End Sub
Private Sub TextBoxRech_Change()
If Me.TextBoxRech <> "" Then
Call NbreItems
mots = Split(Trim(Me.TextBoxRech), " ")
Tbl = choix
For i = LBound(mots) To UBound(mots)
Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
Next i
If UBound(Tbl) > -1 Then
Dim b(): ReDim b(1 To UBound(Tbl) + 1, 1 To NbCol + 1)
For i = LBound(Tbl) To UBound(Tbl)
a = Split(Tbl(i), "|")
j = a(NcolInt)
For c = 1 To NbCol: b(i + 1, c) = TabBD(j, c): Next c
b(i + 1, c) = j
Next i
Me.ListBox1.List = b
Else
Me.ListBox1.Clear
End If
Else
Affiche
'UserForm_Initialize
End If
End Sub
Sub MacroFiltre()
'
' MacroFiltre Macro
'

'
ActiveWorkbook.Worksheets("BD").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("BD").AutoFilter.Sort.SortFields.Add Key:=Range( _
"D1:D51"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("BD").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub NbreItems()
LabelNbre.Caption = ListBox1.ListCount
End Sub
Sub saisie_numéro_facture()
nom = InputBox("Veuillez saisir le numéro de facture", "Message")
TextBox7.Value = nom
End Sub
Sub saisie_montant_facture()
nom = InputBox("Veuillez saisir le montant de la facture", "Message")
TextBox8.Value = nom
End Sub

Merci d'avance pour vos réactions.

24modele-test.zip (354.50 Ko)
Le 27/05/2024 à 13:27

Bonjour linkon007

Vous n'avez pas dû regarder la charte de ce forum ainsi que les options qui existent à priori

Ce n'est pas à moi de vous le dire, mais comme je suis nouveau et que je le sais déjà...

COMMENT POSTER UNE NOUVELLE QUESTION

Joignez (si possible) un fichier pour augmenter vos chances d'obtenir de l'aide en cliquant sur le bouton Fichier de l'éditeur. Si votre fichier est trop lourd ou contient des données personnelles, créez une version allégée de votre fichier avec juste assez d'informations pour permettre de comprendre votre problème. Dans tous les cas, ne postez JAMAIS de fichiers avec des informations personnelles ou confidentielles (cet utilitaire peut vous aider à les retirer).

De plus, il existe un bouton pour insérer du code </>

Voilà
Cordialement

Rechercher des sujets similaires à "exemple userform modification colonnes meme temps"