如何使用阵列字典通过工作表循环

Question

我正在尝试做一些

1. 循环通过值的范围(标题范围(，并将它们收集到数组或其他
2. 制作一个带有键的数组词典，该键是该范围中的值
3. 通过寻找这些钥匙的工作表循环

4. 对于它找到的每个键，

   a。制作以下值的数组

   b。将所有阵列垫垫子，所以它们的长度相同

   c。将其连接到与词典中的数组相同的键

5. 将串联值复制回标题范围以下的单元格

我做了1,2,4和5。我跳过了3，因为这很容易，我稍后再做。但是4很棘手，因为我无法处理字典和阵列的工作方式。我试图制作一个数组词典，但是他们正在制作副本而不是参考，有时副本是空的。我不知道。

在JavaScript中，它只是：

• 制作dict = {}
• 循环通过值并执行dict[value] = []
• 然后dict[value].concatenate(newestarray)
• 然后将dict倒入带有for(var k in dict){}的数组中，在Google表中您必须转介。烦人，但并不可怕。
• 最后，一些功能将其放回工作表中，在Google表中很琐碎。

这是我的四个部分的代码：

With rws
    For Each Key In headerdict 'loop through the keys in the dict
        Set rrng = .Cells.Find(key, , _ 'find the key in the sheet
            Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
            Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
        If rrng Is Not Empty Then
            'find last cell in column of data
            Set rdrng = .Cells(rws.Rows.Count, rrng.Column).End(xlUp)
            'get range for column of data
            Set rrng = .Range(.Cells(rrng.Row + 1, rrng.Column), _
                .Cells(rdrng.Row, rdrng.Column))
            rArray = rrng.Value 'make an array
            zMax = Max(UBound(rArray, 2), zMax) 'set max list length
            fakedict(Key) = rArray 'place array in fake dict for later smoothing
        End If
    Next
End With
For Each Key In fakedict 'now smooth the array
    If fakedict(Key) Is Not Nothing Then
        nArray = fakedict(Key)
        ReDim Preserve nArray(1 To zMax, 1 To 1) 'resize the array
    Else
        ReDim nArray(1 To zMax, 1 To 1) 'or make one from nothing
    End If
    fakedict(Key) = nArray 'add to fake dict
Next

然后，我可以将其合并为真实的命令。所以我的问题是如何调整数组大小？我认为Redim Preserve不是最好的方法。其他人则与收藏夹在一起，但是我有太多的熊猫和python的思想。我习惯于处理矢量，而不是Munge元素。有什么想法吗？

Answer 1

我不确定您是否需要使用数组的字典来实现此目的；如果我这样做，我只会直接在床单之间复制细胞块。第一位 - 确定标题在哪里：

Option Explicit
' Get the range that includes the headers
' Assume the headers are in sheet "DB" in row 1
Private Function GetHeaders() As Range
Dim r As Range
Set r = [DB!A1]
Set GetHeaders = Range(r, r.End(xlToRight))
End Function

第二，确定扫描的床单(我以为它们在同一工作簿中(

' Get all sheets in this workbook that aren't the target DB sheet
Private Function GetSheets() As Collection
Dim sheet As Worksheet
Dim col As New Collection
For Each sheet In ThisWorkbook.Worksheets
  If sheet.Name <> "DB" Then col.Add sheet
Next sheet
Set GetSheets = col
End Function

现在，扫描并复制细胞

' Main function, loop through all headers in all sheets
' and copy data
Sub CollectData()
Dim sheets As Collection, sheet As Worksheet
Dim hdrs As Range, hdr As Range
Dim found As Range
' This is the row we are writing into on DB
Dim currentrow As Integer
' This is the maximum number of entries under a header on this sheet, used for padding
Dim maxcount As Integer
Set sheets = GetSheets
Set hdrs = GetHeaders
currentrow = 1
For Each sheet In sheets
    maxcount = 0
    For Each hdr In hdrs.Cells
    ' Assume each header appears only once in each sheet
        Set found = sheet.Cells.Find(hdr.Value)
        If Not found Is Nothing Then
            ' Check if there is anything underneath
            If Not IsEmpty(found.Offset(1).Value) Then
                Set found = Range(found.Offset(1), found.End(xlDown))
                ' Note the number of items if it's more that has been  found so far
                If maxcount < found.Count Then maxcount = found.Count
                ' Copy cells
                Range(hdr.Offset(currentrow), hdr.Offset(currentrow + found.Count - 1)) = found.Cells.Value
            End If
        End If
    Next hdr
    ' Move down ready for the next sheet
    currentrow = currentrow + maxcount
Next sheet
End Sub

我在Excel 2016中写了这篇文章，并根据我对您的数据的假设进行了测试。