Question

我确信这是一个非常容易解决的问题。我目前有一张excel电子表格，有两张纸。第一个是在A列中具有帐户的工作表，在B列中具有主机数量的空间，然后右侧的其余列是该帐户可以访问的组。在另一张表中，我有2列数据，第一列是主机，第二列是组。我试图计算第一张表中每个帐户的给定帐户关联的主机数量。

由于主机可以位于多个组中，并且该帐户可以与多个组关联，因此可以为帐户计算重复的主机。我试图创建一个宏，循环通过第一个表获取组的值，然后转到第二个表，并将该组的所有主机名放入一个数组。它将为每个组执行此操作，并将主机添加到阵列的末尾，直到它到达给定帐户的组列表的末尾。然后我的宏使用一个函数从数组中删除重复项，然后将数组的计数放入表1中b列的单元格中。

为了制作这个数组，我一直在把我在这个网站上发现的东西放在一起，但我想我有些搞砸了。无论哪个组与帐户关联，宏最终都会在列b中放入相同的数字。

我的代码如下：

Sub PopulatingArrayVariable()
'PURPOSE: Dynamically Create Array Variable based on a Given Size

Dim myArray As Variant
Dim arr2() As Variant
Dim myString As String
Dim x As Long
Dim r As Long
Dim d As Variant
Dim row As Integer
Dim Group As String
Dim endRow As Long

For i = 2 To 5
Worksheets("Sheet1").Activate

    For Each c In Worksheets("Sheet1").Range("C2:I2").Cells 'Finds the group the account belongs to and loops through each of them
    'For c = 3 To 8

    Group = c.Value

    Worksheets("Sheet2").Activate

    endRow = 14 ' of course it's best to retrieve the last used row number via a function
        For r = 1 To endRow

            If Cells(r, Columns("B").Column).Value = Group Then 'adds each host in the group into an array

            myString = myString & ";|;" & Cells(r, 1).Value

            End If

        Next r
    Next 'c

'Remove first delimiter from string (;|;)
   myString = Right(myString, Len(myString) - 3)


'Create an array with the Split() function
    myArray = Split(myString, ";|;")

arr2 = RemoveDupesColl(myArray)

Dim lNumElements As Long

    lNumElements = UBound(arr2) - LBound(arr2) + 1

    Worksheets("Sheet1").Cells(i, 2).Value = lNumElements
myString = Empty

Next i

'Print values to Immediate Window (Ctrl + G to view)
     'For x = LBound(myArray) To UBound(myArray)
      '   Debug.Print myArray(x)
       '  Next x

End Sub

这里是删除重复项功能：

Function RemoveDupesColl(myArray As Variant) As Variant
'DESCRIPTION:  Removes duplicates from your array using the collection method.
'NOTES:  (1)   This function returns unique elements in your array, but
'              it converts your array elements to strings.
'SOURCE: https://wellsr.com
'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(myArray) To UBound(myArray))

    For i = LBound(myArray) To UBound(myArray) 'convert to string
        arrDummy1(i) = CStr(myArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(myArray) To arrColl.Count - LBound(myArray) - 1)
    i = LBound(myArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function

有人可以帮助我弄清楚如何使这项工作或帮助我使用更高效的宏，因为我最终会将这个用于几千个帐户，超过100个组和超过10000个主机。

由于

Answer 1

这将存储来自Sheet2的每个组的唯一主机数（下面显示的嵌套）

主操作在同一行（记录）上为所有组生成一组唯一的主机

预计两个工作表中的第一行为标题，而C上的Sheet1列中的第一行开始

Option Explicit

Public Sub PopulateHosts()
    Dim ws1 As Worksheet:   Set ws1 = Sheet1    'Or ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet:   Set ws2 = Sheet2
    Dim lr1 As Long:        lr1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    Dim lc1 As Long:        lc1 = ws1.UsedRange.Columns.Count
    Dim lr2 As Long:        lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row

    Dim groups As Object:   Set groups = CreateObject("Scripting.Dictionary")

    Dim r As Long, c As Long, arr As Variant, h As String, g As String, hosts As Object

    arr = ws2.Range(ws2.Cells(1, 1), ws2.Cells(lr2, 2))             'Sheet2 - Hosts
    For r = 2 To lr2                'Exclude Headers
        h = arr(r, 1)               'Convert host to string (number to string)
        g = arr(r, 2)               'Convert group to string (number to string)
        If Not groups.Exists(g) Then
            Set hosts = CreateObject("Scripting.Dictionary")
            hosts(h) = 0
            Set groups(g) = hosts
        Else
            groups(g)(h) = 0
        End If
    Next

    Dim itm As Variant, u As Object

    arr = ws1.Range(ws1.Cells(1, 1), ws1.Cells(lr1, lc1)).Formula   'Sheet1 - Accounts
    For r = 2 To lr1                'Exclude Headers
        Set u = CreateObject("Scripting.Dictionary")
        For c = 3 To lc1
            g = arr(r, c)           'Convert any group (number to string)
            If groups.Exists(g) Then
                For Each itm In groups(g)
                    u(itm) = 0      'Extract unique hosts for all groups in this row
                Next
            End If
        Next
        arr(r, 2) = u.Count
    Next
    ws1.Range(ws1.Cells(1, 1), ws1.Cells(lr1, lc1)).Formula = arr
End Sub

性能

ws1.Rows (Accounts): 10,001
ws2.Rows (Hosts):   100,002 (Groups: 10,000)
Time:   2.238 sec

嵌套词典 - 结构（仅限键）：

Group: 1 -> Host: H2      (not unique in set: Group 1 + Group 4)
Group: 1 -> Host: H5      (not unique in set: Group 1 + Group 4)
Group: 1 -> Host: H10002
Group: 1 -> Host: H20002
Group: 1 -> Host: H30002
...
Group: 1 -> Host: H90002

Group: 2 -> Host: H3      (not unique in set: Group 2 + Group 3)
Group: 2 -> Host: H4      (not unique in set: Group 2 + Group 3)
Group: 2 -> Host: H10003
Group: 2 -> Host: H20003
Group: 2 -> Host: H30003
...
Group: 2 -> Host: H90003

Group: 3 -> Host: H4      (not unique in set: Group 2 + Group 3)
Group: 3 -> Host: H3      (not unique in set: Group 2 + Group 3)
Group: 3 -> Host: H10004
Group: 3 -> Host: H20004
Group: 3 -> Host: H30004
...
Group: 3 -> Host: H90004

Group: 4 -> Host: H5      (not unique in set: Group 1 + Group 4)
Group: 4 -> Host: H2      (not unique in set: Group 1 + Group 4)
...

测试数据

<强> Sheet1

<强> Sheet2

与帐户有权访问的组关联的唯一主机数

1 个答案: