Question

我有一个数据库，我应该在其中显示公司中每位员工的培训列表。培训在我的excel工作表中的单元格（A，41）中：

我编写了代码，帮助我为培训创建了一个新列表，没有重复，并且仅显示每次培训的最新日期，如下所示：

但是，当我在用户窗体中显示结果时，却有重复项：

我的代码是：

Private Sub tri_PE()
Dim dercol As Long, t, i As Long, j As Long, dico, x, ech As Boolean

With ActiveWorkbook.Worksheets(Personne)
'   With Sheets("DEBEYER Nicolas")
      'lecture du tableau des formations
      dercol = .Cells(41, .Rows.Columns.Count).End(xlToLeft).Column
      t = Application.Transpose(.Range("41:42").Resize(, dercol).Value2)

      'tri de t sur la première colonne (numéro de foemation) sans les en-têtes
      Do
         ech = False
         For i = 2 To UBound(t) - 1
            If t(i + 1, 1) < t(i, 1) Then
               x = t(i, 1): t(i, 1) = t(i + 1, 1): t(i + 1, 1) = x
               x = t(i, 2): t(i, 2) = t(i + 1, 2): t(i + 1, 2) = x: ech = True
            End If
         Next i
      Loop Until Not ech

      ' conversion des numéros en texte (pour le dico et la listbox)
      ' et les fausses dates (en texte) en vraies dates
      On Error GoTo PasDate
      For i = 2 To UBound(t)
         t(i, 1) = CStr(t(i, 1))
         If TypeName(t(i, 2)) = "String" Then t(i, 2) = 1 * DateSerial(Right(t(i, 2), 4), Mid(t(i, 2), 4, 2), Left(t(i, 2), 2))
      Next i
      On Error Resume Next

      'remplissage de dico
      Set dico = CreateObject("scripting.dictionary")
      dico.CompareMode = TextCompare
      For i = 2 To UBound(t)
         If t(i, 1) <> "" Then
            If Not dico.Exists(t(i, 1)) Then
               dico.Add t(i, 1), t(i, 2)
            Else
               If t(i, 2) > dico(t(i, 1)) Then dico(t(i, 1)) = t(i, 2)
            End If
         End If
      Next i

   'Transfert de dico vers le tableau r pour la liste
   ReDim r(1 To dico.Count, 1 To 2): i = 0
   For Each x In dico.Keys: i = i + 1: r(i, 1) = x: r(i, 2) = dico(x): Next

   'remplissage des lignes 48 et 49 de la feuille de chaque personne
   .Range("b48:b49").Resize(, Columns.Count - 1).Clear
   .Range("b48").Resize(1, UBound(r)).NumberFormat = "000"
   .Range("b48").Resize(1, UBound(r)).HorizontalAlignment = xlCenter
   .Range("b49").Resize(1, UBound(r)).NumberFormat = "dd/mm/yyyy"
   .Range("b48").Resize(2, UBound(r)).Borders.LineStyle = xlContinuous
   .Range("b48:b49").Resize(2, UBound(r)) = Application.Transpose(r)

   End With

   'remplissage de la listbox
   For i = 1 To UBound(r): r(i, 1) = Format(r(i, 1), "000"): r(i, 2) = Format(r(i, 2), "dd/mm/yyyy"): Next

   With ListBox1
      .ColumnCount = 2
      .ColumnHeads = False
      .ColumnWidths = .Width * 0.7        '& ";" & .Width * (1 - 0.6 + 0.1)
      .List = r
   End With
   Exit Sub


PasDate:
   MsgBox "La valeur de la cellule " & Cells(42, i).Address(0, 0) & " ne peut être convertie en date  -> Echec et Fin.", vbCritical
   ActiveWorkbook.Worksheets(Personne).Cells(42, i).Select
   End
End Sub

如何删除列表框中的重复项？谢谢

Answer 1

找到了解决方案：在填充列表框的代码末尾添加以下行：

Sample_PE

其中：

Sub Sample_PE()
RemovelstDuplicates UF_Profil_Edit1.ListBox_PE
End Sub

并将此代码放在模块中：

'Remove Duplicates
Public Sub RemovelstDuplicates(lst As MSForms.ListBox)
    Dim i As Long, j As Long
    With lst
        For i = 0 To .ListCount - 1
            For j = .ListCount - 1 To (i + 1) Step -1
                If .List(j) = .List(i) Then
                    .RemoveItem j
                End If
            Next
        Next
    End With
End Sub

然后解决了pb :)

按最近日期对项目进行排序VBA

1 个答案: