Hello.... Please help me change the History Column combobox link to column B
My problem is that it retrieves the data from the column of the month
My problem is that it retrieves the data from the column of the month
VBA Code:
Option Compare Text
Dim f, NomTableau, TabBD(), ColCombo(), colVisu(), colInterro(), NcolVisu, NbCol, NcolInt, Choix()
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Set Rng = f.Range("A2:J" & 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(1, 5, 6, 7, 8) ' A adapter (1 à 6 colonnes maxi)
colVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ' Colonnes ListBox (à adapter)
colInterro = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ' 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
'---dates
colDate = 1
Set d = CreateObject("scripting.dictionary")
For i = LBound(TabBD) To UBound(TabBD)
d(TabBD(i, colDate)) = ""
Next i
Dates = d.keys
Tri Dates, LBound(Dates), UBound(Dates)
Me.DateMini.List = Dates: Me.DateMini = Dates(0)
Me.DateMaxi.List = Dates: Me.DateMaxi = Dates(UBound(Dates))
'-- en têtes de colonnes ListBox
EnteteListBox ' Supprimer sur Excel 2013
'-- labels textbox
LabelsTextBox
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
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 LabelsTextBox()
For c = 1 To NbCol
Me("textbox" & c).Width = Range(NomTableau).Columns(c).Width * 1.3
tmp = Range(NomTableau).Offset(-1).Item(1, c)
Me("label" & c).Caption = tmp
lg = Len(tmp): If Len(tmp) > 11 Then lg = 11
Me("label" & c).Width = lg * 6
Next
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()
If Me.DateMini = "" Or Me.DateMaxi = "" Then Exit Sub
Dim Tbl()
cbx1 = Me.ComboBox1: cbx2 = Me.ComboBox2: cbx3 = Me.ComboBox3: cbx4 = Me.ComboBox4: cbx5 = Me.ComboBox5: cbx6 = Me.ComboBox6
n = 0
dMini = CDate(Me.DateMini): dMaxi = CDate(Me.DateMaxi)
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 _
And TabBD(i, 1) >= dMini And TabBD(i, 1) <= dMaxi 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
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 DateMaxi_Change()
Affiche
End Sub
Private Sub DateMini_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
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()
If Me.ListBox1.ListCount = 0 Then Exit Sub
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
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
test_user_2023
MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.
www.mediafire.com