Question

由于我是VBA excel的新手，所以我不知道如何解决以下问题。

我创建了一个用户输入表单，用户可以使用该表单输入项目详细信息。每当需要更新项目详细信息时，都可以使用此用户输入表单。这些条目将存储在另一个名为“项目更新历史记录”的工作表中。此列表包含每个项目的所有更新条目（如下表所示）。

/--------------------------------------------------------------\
|      |  EntryDate    | Project Name | Project ID | Status    |
|--------------------------------------------------------------|
|  1   | 01.02.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  2   | 01.02.2018    | CDE          |   P002     |  text     |
|--------------------------------------------------------------|
|  3   | 15.02.2018    | CDE          |   P002     |  text     |
|--------------------------------------------------------------|
|  4   | 16.02.2018    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  5   | 08.08.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  6   | 09.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  7   | 14.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  8   | 12.12.2019    | CDE          |   P002     |  text     |
\--------------------------------------------------------------/

enter image description here

您可以想象，有数百个条目，并且很难获得概述。理想情况下，在单独的工作表中有一个仅具有最新项目状态的列表。（请参见下表）

/--------------------------------------------------------------\
|      |  EntryDate    | Project Name | Project ID | Status    |
|--------------------------------------------------------------|
|  1   | 08.08.2018    | ABC          |   P001     |  text     |
|--------------------------------------------------------------|
|  2   | 14.09.2019    | FGH          |   P003     |  text     |
|--------------------------------------------------------------|
|  3   | 12.12.2019    | CDE          |   P002     |  text     |
\--------------------------------------------------------------/

enter image description here

为了得到这个，我已经尝试了不同的选择，例如使用“过滤器”或“数组公式”。但是，两者都不尽如人意。筛选器并没有真正的帮助，因为我想一次查看所有项目（但仅是最新的项目更新）。数组公式实际上给了我输出，我想要……但是excel文件变得非常慢。（要获取最新的输入日期{= MAX（IF（'Project Update History'！C：C = C4，'Project Statuses'！B：B，0））}} （要获取相应的条目详细信息，请使用INDEX匹配公式。）

因此，唯一可以避免此问题的方法是使用宏。我的想法是要有一个按钮，该按钮可以搜索每个项目的最新状态并显示在工作表中……但是我真的不知道该如何编写代码……也许其他人也遇到了这个问题并找到了解决方案？我真的很感谢您的任何帮助。：）

在此先感谢您的帮助。

尼罗

Answer 1

这是使用数组的一种方法。根据您数据的大小，Transpose可能会达到极限，在这种情况下，我可以重写部分解决方案。

在连接在一起时，我使用了“，”分隔符来跟踪单独的列项目。您可能希望使用不希望在数据中找到的符号来代替它，以确保不会导致意外的结果。如果更改定界符，请在此处更改Const DELIMITER As String = ","的值。

Option Explicit
Public Sub GetLastDateInfo()
    Application.ScreenUpdating = False
    Const DELIMITER As String = ","
    Dim arr(), resultsArr(), dict As Object, i As Long, currDate As Long, ws As Worksheet, headers()
    headers = Array("Entry Date", "Project Date", "Project ID", "Status")
    Set ws = ThisWorkbook.Worksheets("Sheet1"): Set dict = CreateObject("Scripting.Dictionary")
    arr = ws.Range("A2:D" & GetLastRow(ws, 1)).Value
    ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = LBound(arr, 1) To UBound(arr, 1)
        currDate = CLng(CDate(Replace$(arr(i, 1), ".", "-")))
        If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
            dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate & DELIMITER & arr(i, 4)
        ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
            dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate & DELIMITER & arr(i, 4)
        End If
    Next i
    Dim key As Variant, r As Long, tempArr() As String
    For Each key In dict.keys
        r = r + 1
        tempArr = Split(dict(key), DELIMITER)
        resultsArr(r, 1) = tempArr(0)
        resultsArr(r, 4) = tempArr(1)
        tempArr = Split(key, DELIMITER)
        resultsArr(r, 2) = tempArr(0)
        resultsArr(r, 3) = tempArr(1)
    Next key
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    With Worksheets("Sheet2")
        .Range("A1").Resize(1, UBound(headers) + 1) = headers
        .Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

输出：

适用于增加的列数（使用上面的GetLastRow函数）：

 Public Sub GetLastDateInfo2()
    Application.ScreenUpdating = False
    Const DELIMITER As String = ","
    Dim arr(), resultsArr(), dict As Object, dict2 As Object, i As Long, j As Long
    Dim currDate As Long, ws As Worksheet, headers()
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = ws.Range("A1:AN1").Value
    headers = Application.WorksheetFunction.Index(headers, 1, 0)
    Set dict = CreateObject("Scripting.Dictionary"): Set dict2 = CreateObject("Scripting.Dictionary")
    arr = ws.Range("A2:AN" & GetLastRow(ws, 1)).Value
    ReDim resultsArr(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = LBound(arr, 1) To UBound(arr, 1)
        currDate = CLng(CDate(Replace(arr(i, 1), ".", "-")))
        If Not dict.Exists(arr(i, 2) & DELIMITER & arr(i, 3)) Then
            dict.Add arr(i, 2) & DELIMITER & arr(i, 3), currDate
            dict2.Add arr(i, 2) & DELIMITER & arr(i, 3), arr(i, 4)
            For j = 5 To UBound(arr, 2)
                dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
            Next j
        ElseIf Split(dict(arr(i, 2) & DELIMITER & arr(i, 3)), DELIMITER)(0) < currDate Then
            dict(arr(i, 2) & DELIMITER & arr(i, 3)) = currDate
            dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = vbNullString
            For j = 4 To UBound(arr, 2)
                dict2(arr(i, 2) & DELIMITER & arr(i, 3)) = dict2(arr(i, 2) & DELIMITER & arr(i, 3)) & DELIMITER & arr(i, j)
            Next j
        End If
    Next i
    Dim key As Variant, r As Long, tempArr() As String

    For Each key In dict.keys
        r = r + 1
        tempArr = Split(dict(key), DELIMITER)
        resultsArr(r, 1) = tempArr(0)
        tempArr = Split(key, DELIMITER)
        resultsArr(r, 2) = tempArr(0)
        resultsArr(r, 3) = tempArr(1)
        resultsArr(r, 4) = Replace$(dict2(key), DELIMITER, vbNullString, , 1)
    Next key
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    ReDim Preserve resultsArr(1 To UBound(resultsArr, 1), 1 To r)
    resultsArr = Application.WorksheetFunction.Transpose(resultsArr)
    Application.DisplayAlerts = False
    With Worksheets("Sheet2")
         .UsedRange.ClearContents
        .Range("A2").Resize(UBound(resultsArr, 1), UBound(resultsArr, 2)) = resultsArr
        .Columns("D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote,Other:=True, OtherChar _
        :=DELIMITER, TrailingMinusNumbers:=True
        .Range("A1").Resize(1, UBound(headers)) = headers
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

如何查找每个组的最新条目并如何在Excel中的单独工作表中显示

1 个答案: