如何使用數組字典循環工作表

Question

我想做點什么

1. 循環遍歷值的范圍（標題范圍）並將它們收集到數組或其他任何內容中
2. 使用鍵作為范圍中的值來創建數組的字典
3. 循環通過工作表尋找這些鍵

4. 對於它找到的每個鍵，

   一種。 在下面創建一個值數組

   灣 填充所有數組，使它們的長度相同

   C。 使用相同的密鑰將其連接到存儲在字典中的數組

5. 將連接的值復制回標題范圍下方的單元格

我做了1,2,4和5.我跳過3，因為這很容易，我會在以后再做。 但是4很棘手，因為我無法處理字典和數組的工作方式。 我試圖制作一個數組字典，但它們是復制而不是引用，有時復制是空的。 我不知道。

在javascript中，它只是：

• 做一個dict = {}
• 循環遍歷值並執行dict[value] = []
• 然后dict[value].concatenate(newestarray)
• 然后將dict重新轉換為帶有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是最好的方法。 其他人已經收集了藏品，但我有太多的熊貓和蟒蛇的想法。 我習慣於處理向量，而不是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中編寫了這個，並根據我對數據布局的假設進行了測試。