Question

我有12,000多行来排序这些数据，我们非常感谢您的帮助！

首先，我需要检查唯一ID的帐户名称。

让我们说A00001，有产品，互换和调整 - 变化。

正如您所看到的，这些帐户名被列为唯一ID A00001的多次，但我只需要知道A0001包含哪些帐户名，而不是每个帐户名列出的次数。

我将获取我找到的3个帐户名称，并将它们放在工作表的“组”标签中，如下图所示，并创建一个组＃1。如果12,000多行中的另一个唯一ID仅包含帐户名称产品，交换和调整 - 更改帐户，那么我会将其分配给第1组（绿色圆圈）。

在下一组唯一ID A00002中，重新发生的帐户名称为产品和交换。所以我将创建一个＃2组。我不会将此分配给组＃1，因为它不包含组＃1所有的所有3个帐户名称。

对于A00003，它只包含产品和交换，因此我将为其分配一组＃2。

所以我要问的是，是否有一个excel公式或VBA代码可用于自动化？

Answer 1

您的帖子被低估的原因是您尚未生成任何可证明您至少尝试解决此问题的代码或公式。你的问题很模糊：

是否有自动执行此操作的VBA代码？

答案：是的！

我们的工作并不是我们能够为您阐明您的问题，这就是为什么对您的帖子的回复相当稀少的原因。但是，你的问题中有几点也可能对其他人有用，所以我会尽我所能回答。

第1点：只要您拥有相当大的数据集（在您的情况下为200,000），通常最好将数据读入Variant数组并在VBA中处理数据。这是一项简单的任务v = Range(A1:D200000).Value2，速度非常快。

第2点：我认为您的帐户名称不一定要排序。因此，一个客户可以拥有＆＃39;产品和互换＆＃39;组合，而另一个可能有互换和产品＆＃39;。你还没有说明这一点，但我想我们必须迎合这种可能性。在这些情况下，解决方案是将每个项目转换为数字索引，该索引允许类似于二进制加法的内容。例如，＆＃39;产品＆＃39; = 1，＆＃39;掉头＆＃39; = 2和＆＃39; Adj＆＃39; = 4然后产品和互换的组合（以任何顺序）将给出一个独特的总和3;交换和adj唯一给6等。

你的任务的解决方案可能就在这条路的某个地方。下面的代码将帮助您开始使用它，我在整个评论中为您提供进一步的指导。

我注意到这是你的第一篇文章，所以我应该解释一下，这个网站的目的不是提供无偿编码服务。当你遇到一个不可逾越的障碍时，它意味着帮助你和他人。因此，请尝试理解代码并熟悉VBA，以便您可以自己开发这个框架代码;并且，如果我可以冒昧地提供建议，那么就应该避免回复评论，这样做不会起作用。＆＃34;

祝你的项目好运，将以下代码粘贴到你的VBA编辑器中的Module：

Option Explicit
Private Const UNIQUE_ID_INDEX As Integer = 0
Private Const ACC_LIST_INDEX As Integer = 1
Private Const ALLOCATION_INDEX As Integer = 2
Private Const GROUP_NAME_INDEX As Integer = 0
Private Const GROUP_LIST_INDEX As Integer = 1
Private Const ROW_KEY As String = "row"
Private Const GROUP_KEY As String = "group"
Private Const SOURCE_SHEET_FIRST_ROW As Long = 2
Private Const SOURCE_SHEET_FIRST_COL As Long = 1
Private Const SOURCE_SHEET_LAST_COL As Long = 3
Private Const GROUP_SHEET_FIRST_ROW As Long = 1
Private Const GROUP_SHEET_FIRST_COL As Long = 2
Public Sub RunMe()
    Dim src As Worksheet
    Dim grp As Worksheet
    Dim lastRow As Long
    Dim data As Variant
    Dim output() As Variant
    Dim idList As Collection
    Dim groupList As Collection
    Dim accList As Collection
    Dim accKeyList As Collection
    Dim accIndex As Long
    Dim accName As String
    Dim idItems As Variant
    Dim uniqueID As String
    Dim groupItems As Variant
    Dim maxSize As Long
    Dim added As Boolean
    Dim c As Long
    Dim h As Long
    Dim v As Variant

    ' Read the data from the data sheet
    Set src = ThisWorkbook.Worksheets("Sheet1") 'adjust to your source data sheet name.
    lastRow = src.Cells.Find(What:="*", _
                            After:=src.Cells(1), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False, _
                            SearchFormat:=False).Row

    data = src.Range(src.Cells(SOURCE_SHEET_FIRST_ROW, SOURCE_SHEET_FIRST_COL), _
           src.Cells(lastRow, SOURCE_SHEET_LAST_COL)).Value2

    'Process the data into lists of unique acc names and IDs
    Set accList = New Collection
    Set accKeyList = New Collection
    Set idList = New Collection
    c = 1
    For h = 1 To UBound(data, 1)

        'Convert account names to unique binary indexes
        accName = data(h, 2)
        accIndex = GetOrAdd(accName, accList, c, added)
        If added Then
            accKeyList.Add accName, CStr(c)
            c = c + c
        End If

        'Create a list of uniqueIDs and a list of row numbers for each new uniqueID
        uniqueID = data(h, 3)
        idItems = GetOrAdd(uniqueID, idList, Array(uniqueID, New Collection, New Collection), added)
        If added Then idItems(ALLOCATION_INDEX).Add h, ROW_KEY

        'Add the account index to this uniqueID group
        Call IgnoreOrAdd(CStr(accIndex), idItems(ACC_LIST_INDEX), accIndex)
    Next

    'Sum each account index in the uniqueID group
    'to obtain a binary value that is unique
    'to this combination of account names
    'and create a new group if the binary value is new.
    Set groupList = New Collection
    maxSize = 0
    c = 1
    For Each idItems In idList
        h = 0
        For Each v In idItems(ACC_LIST_INDEX)
            h = h + v
        Next

        groupItems = GetOrAdd(CStr(h), groupList, Array(c, idItems(ACC_LIST_INDEX)), added)
        If added Then
            c = c + 1
            'Get max size of list to dimension output array
            h = groupItems(GROUP_LIST_INDEX).Count
            If h > maxSize Then maxSize = h
        End If

        'Assign group name to uniqueID
        idItems(ALLOCATION_INDEX).Add groupItems(GROUP_NAME_INDEX), GROUP_KEY

    Next

    'Write the group output onto the source data sheet
    ReDim output(1 To UBound(data, 1), 1 To 1)
    For Each idItems In idList
        output(idItems(ALLOCATION_INDEX).Item(ROW_KEY), 1) = _
            idItems(ALLOCATION_INDEX).Item(GROUP_KEY)
    Next
    src.Cells(SOURCE_SHEET_FIRST_ROW, SOURCE_SHEET_LAST_COL + 1) _
        .Resize(UBound(output, 1), UBound(output, 2)).Value = output

    'Write the group summary output onto the summary sheet
    Set grp = ThisWorkbook.Worksheets("Sheet2") 'adjust to your group summary sheet name.
    ReDim output(1 To maxSize + 1, 1 To groupList.Count + 1)
    output(1, 1) = "Group #"
    'Loop through group list to read the individual acc names.
    c = 2
    For Each groupItems In groupList
        output(1, c) = groupItems(GROUP_NAME_INDEX)
        h = 2
        For Each v In groupItems(GROUP_LIST_INDEX)
            accName = accKeyList(CStr(v))
            output(h, c) = accName
            h = h + 1
        Next
        c = c + 1
    Next
    grp.Cells(GROUP_SHEET_FIRST_ROW, GROUP_SHEET_FIRST_COL) _
        .Resize(UBound(output, 1), UBound(output, 2)).Value = output

End Sub
Private Function GetOrAdd(ByVal key As String, _
                          ByRef col As Collection, _
                          ByVal newValue As Variant, _
                          Optional ByRef added As Boolean) As Variant
    Dim v As Variant

    v = Empty
    On Error Resume Next
    v = col(key)
    On Error GoTo 0

    If IsEmpty(v) Then
        v = newValue
        col.Add v, key
        added = True
    Else
        added = False
    End If

    GetOrAdd = v

End Function
Private Sub IgnoreOrAdd(ByVal key As String, _
                        ByRef col As Variant, _
                        ByVal newValue As Variant, _
                        Optional ByRef added As Boolean)
    Dim v As Variant

    v = Empty
    On Error Resume Next
    v = col(key)
    On Error GoTo 0

    If IsEmpty(v) Then
        col.Add newValue, key
        added = True
    End If

End Sub

Excel公式用于查看不同的帐户＃，并查找每个帐户的描述，并在不同的列中创建它们的集合

1 个答案: