Combobox中的独特值，利用另一个范围的最大日期

Posted 2021-05-03

我正在尝试自学VBA（主要是在Excel 2010中）并且我坚持使用一些代码。我利用Excel之类的网站，Excel很有趣，以及谷歌带我去的其他地方，但我找不到对我有用的指导。

挑战：我的用户表单有一个读取范围的组合框。问题是，范围所在的工作表可能有多个重复值，但我只想查看唯一值。为了使它更具挑战性（对我而言），当用户选择组合框中的值时，我希望该数据集流回到表单。

我已经设法将数据恢复到表单上，但是我很难获得MAX“输入日期”记录。所以，如果有5个名称为“Tom”的实例，其中“Entered Dates”为5/1 / 17,6 / 1 / 17,7 / 1 / 17,8 / 17 / 17,12 / 1/17;我希望看到12/1/17的记录。

似乎我需要对集​​合做一些事情以获得组合框中的独特价值，但我不理解它是如何工作的。我也不知道如何将它全部绑定到MAX“输入日期”。这是我到目前为止的代码：

Private Sub cmd_Submit_Click()

Dim ws1 As Worksheet

Set ws1 = ThisWorkbook.Sheets("Client Measurements")

LastRow = ws1.Range("C" & Rows.Count).End(xlUp).Row + 1

ws1.Range("B" & LastRow) = Me.txt_Updated
ws1.Range("C" & LastRow) = Me.txt_First
ws1.Range("D" & LastRow) = Me.txt_Last
ws1.Range("E" & LastRow) = Me.txt_Suffix
ws1.Range("F" & LastRow) = Me.cobo_Name
ws1.Range("G" & LastRow) = Me.txt_EntryType
ws1.Range("H" & LastRow) = Me.txt_Height
ws1.Range("I" & LastRow) = Me.txt_Weight
ws1.Range("J" & LastRow) = Me.txt_Chest
ws1.Range("K" & LastRow) = Me.txt_Hips
ws1.Range("L" & LastRow) = Me.txt_Waist
ws1.Range("M" & LastRow) = Me.txt_BicepL
ws1.Range("N" & LastRow) = Me.txt_BicepR
ws1.Range("O" & LastRow) = Me.txt_ThighL
ws1.Range("P" & LastRow) = Me.txt_ThighR
ws1.Range("Q" & LastRow) = Me.txt_CalfL
ws1.Range("R" & LastRow) = Me.txt_CalfR


End Sub
Private Sub cobo_Name_DropButtonClick()

Dim i As Long
Dim coll As Collection
Dim ws1 As Worksheet

Set ws1 = ThisWorkbook.Sheets("Client Measurements")

LastRow = Sheets("Client Measurements").Range("F" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Sheets("Client Measurements").Cells(i, "F").Value = (Me.cobo_Name) Or _
Sheets("Client Measurements").Cells(i, "F").Value = Val(Me.cobo_Name) Then
    Me.txt_First = Sheets("Client Measurements").Cells(i, "C").Value
    Me.txt_Last = Sheets("Client Measurements").Cells(i, "D").Value
    Me.txt_Suffix = Sheets("Client Measurements").Cells(i, "E").Value
    Me.txt_Height = Sheets("Client Measurements").Cells(i, "H").Value
    Me.txt_Weight = Sheets("Client Measurements").Cells(i, "I").Value
    Me.txt_Chest = Sheets("Client Measurements").Cells(i, "J").Value
    Me.txt_Hips = Sheets("Client Measurements").Cells(i, "K").Value
    Me.txt_Waist = Sheets("Client Measurements").Cells(i, "L").Value
    Me.txt_BicepL = Sheets("Client Measurements").Cells(i, "M").Value
    Me.txt_BicepR = Sheets("Client Measurements").Cells(i, "N").Value
    Me.txt_ThighL = Sheets("Client Measurements").Cells(i, "O").Value
    Me.txt_ThighR = Sheets("Client Measurements").Cells(i, "P").Value
    Me.txt_CalfL = Sheets("Client Measurements").Cells(i, "Q").Value
    Me.txt_CalfR = Sheets("Client Measurements").Cells(i, "R").Value


End If
Next
End Sub

Private Sub UserForm_Initialize()

Dim ws1 As Worksheet
Dim cCMName As Range

Set ws1 = ThisWorkbook.Sheets("Client Measurements")

For Each cCMName In ws1.Range("CMName")
    With Me.cobo_Name
        .AddItem cCMName.Value
    End With
Next cCMName

txt_EntryType = "Check In"

End Sub

答案

不是你的问题的确切答案，而是一个如何解决它的例证。这使用了一个字典。如果B中的新值高于现有项，则添加键和项对并更新项。

Sub x()

Dim vData, r As Long

vData = Range("A1").CurrentRegion.Value

With CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(vData, 1)
        If vData(r, 2) > .Item(vData(r, 1)) Then
            .Item(vData(r, 1)) = vData(r, 2)
        End If
    Next r
    Range("D1").Resize(.Count) = Application.Transpose(.keys)
    Range("E1").Resize(.Count) = Application.Transpose(.items)
End With

End Sub

另一答案

我将在一个单独的帖子中发布一个新问题，但意识到我从未将此问题标记为已回答。这是解决我的问题的代码：

Set coboDict = CreateObject("Scripting.Dictionary")
With coboDict
For Each cStatsClientID In ws1.Range("StatsClientID")
    If Not .exists(cStatsClientID.Value) Then
        .Add cStatsClientID.Value, cStatsClientID.Row
    Else
        If CLng(cStatsClientID.Offset(, -2).Value) > CLng(ws1.Range("B" & .Item(cStatsClientID.Value))) Then
        .Item(cStatsClientID.Value) = cStatsClientID.Row
        End If
    End If
Next cStatsClientID
Me.cobo_ClientID.List = Application.Transpose(.keys)
End With