arrays - 如何使用数组字典循环工作表

Question

我正在尝试做一些东西

1. 循环遍历一系列值( header 范围)并将它们收集到数组或其他内容中
2. 创建一个数组字典，其键为范围内的值
3. 循环遍历工作表寻找这些键

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

   a.创建一个包含以下值的数组

   b.填充所有数组，使其长度相同

   c.将其连接到具有相同键的字典中存储的数组

5. 将连接的值复制回标题范围下方的单元格

我做了 1、2、4 和 5。我跳过了 3，因为这很简单，我稍后会做。但 4 很棘手，因为我无法掌握字典和数组的工作原理。我尝试制作数组字典，但他们制作的是副本而不是引用，有时副本是空的。我不知道。

在 JavaScript 中，它只是:

• 创建一个 dict = {}
• 循环遍历值并执行dict[value] = []
• 然后dict[value].concatenate(newestarray)
• 然后使用 for(var k in dict){} 将字典翻转回数组，在 Google 表格中您必须转置该数组。烦人，但并不可怕。
• 最后，使用一些函数将其放回工作表中，这在 Google 表格中是微不足道的。

这是我的第 4 部分的代码:

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 是最好的方法。其他人对集合进行了破坏，但我有太多的 Pandas 和 python 思维。我习惯于处理向量，而不是 munge 元素。有什么想法吗？

Answer 1

我不确定您是否需要使用数组字典来实现此目的；如果我这样做，我会直接在工作表之间复制单元格 block 。第一个位 - 确定 header 的位置:

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 中编写了此内容，并根据我对数据布局方式的假设测试了它是否有效。