Question

我试图制作一些

遍历值的范围（标题范围）并将它们收集到数组或其他任何
使用
遍历工作表寻找这些键
找到的每个键，

一个。制作以下值的数组

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

℃。使用相同的键将它连接到存储在字典中的数组
将连接的值复制回标题范围

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

在javascript中，它只是：

制作dict = {}
循环显示值并执行dict[value] = []
然后dict[value].concatenate(newestarray)
然后将字典翻转回一个带有for(var k in dict){}的数组，在谷歌工作表中你必须转置。烦人，但并不可怕。
然后最后，将一些函数重新放回到工作表中，在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中写了这个，并根据我对数据布局的假设进行了测试。

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

1 个答案: