Edit a Combobox date link From column 1 to column 2

S

sofas

Well-known Member
Joined
Sep 11, 2022
Messages
559
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
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



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


www.mediafire.com

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
 

Attachments

  • Capture.PNG
    Capture.PNG
    29.2 KB · Views: 11

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
In this code, change this line:
colDate = 1

By this line:
colDate = 2

Rich (BB code): 
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 = 2
 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
 
Upvote 0
Solution
DanteAmor said:
In this code, change this line:
colDate = 1

By this line:
colDate = 2

Rich (BB code): 
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 = 2
 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
Click to expand...
Unfortunately, there is an error message despite changing it to colDate = 2
With the data not appearing on the listbox. I wish you had a quick look at the file
 

Attachments

  • Screenshot 2023-02-05 002702.png
    Screenshot 2023-02-05 002702.png
    38.6 KB · Views: 11
Upvote 0
That's another kind of problem.
To load the dates that are in column "B", you must first change to 2.

The min and max combos with 1:
1675554174182.png


-----------------------------------------

Now With 2:
1675554121099.png



----- ---

sofas said:
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
Click to expand...
Your original request is the problem of the date and column B.

I'm afraid you'll have to fix any problems you have in the other parts of your code. Close this thread and create a new thread for each problem.
 
Upvote 0
DanteAmor said:
That's another kind of problem.
To load the dates that are in column "B", you must first change to 2.

The min and max combos with 1:
View attachment 84629

-----------------------------------------

Now With 2:
View attachment 84628


----- ---


Your original request is the problem of the date and column B.

I'm afraid you'll have to fix any problems you have in the other parts of your code. Close this thread and create a new thread for each problem.
Click to expand...
Yes, the change has already been made, but then other problems appeared, I do not know why
 
Upvote 0
Please, who has any idea similar to filtering data on several criteria by means of combobox with the possibility of filtering between two dates, to guide me to it. I found what I'm looking for in this file. I only need to search between two dates. Unfortunately, when I changed the date column from 1 to 2 to match my original file, I didn't succeed... The listbox data disappeared. And an error message when trying to filter!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Hello, how do I add column headers to listbox
Replies
3
Views
949
Herakles
H
I
  • Solved
Advice to use the same code but from top of sheet down the page
Replies
2
Views
68
ipbr21054
I
S
  • Question Question
Copy the LISTBOX data in the first empty row
Replies
3
Views
311
sofas
S
M
  • Question Question
Re-produce code to copy last row from listbox on userform to sheet
Replies
3
Views
166
MKLAQ
M
A
  • Question Question
Vba code for data fetching from nseindia
Replies
0
Views
528
asp123
A

Forum statistics

Threads
1,224,820
Messages
6,181,160
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top