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

Question

我想做点什么

1. 循环遍历值的范围(标题范围)并将它们收集到数组或其他任何内容中
2. 使用键作为范围中的值来创建数组的字典
3. 循环通过工作表寻找这些键

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

   一个.在下面创建一个值数组

   湾 填充所有数组,使它们的长度相同

   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是最好的方法.其他人已经收集了藏品,但我有太多的熊猫和蟒蛇的想法.我习惯于处理矢量,而不是处理元素.有任何想法吗？

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