Arrays VBA代码，用于创建工人工作周数的多维数组

长期读者，第一次发布

我试图创建一个数组，其中包含一个工作人员列表，以及工作人员在源表中列出的每周。例如，源数据基本上如下所示：

| Worker # | Week |
| 1        | 1/1  |
| 1        | 1/8  |
| 1        | 1/15 |
| 2        | 1/1  |
| 3        | 1/8  |
| 3        | 1/15 |

我希望得到的数组是：

|  1  | 1/1  | 1/8  | 1/15 |
|  2  | 1/1  |
|  3  | 1/8  | 1/15 |

---

在上下文中，我试图创建一个多维数组，其中包含每个员工提交时间表的周数，以便将其与每个员工本应工作的多维数组进行比较。目标是确定缺少的时间表。如果有比使用阵列更优雅的解决方案，我愿意听听。谢谢大家!

您可以使用字典获取行号和列号，并将值放入数组中

Sub test()
    Dim Ws As Worksheet, toWs As Worksheet
    Dim vDB, vR()
    Dim DicR As Object 'Dictionary
    Dim DicC As Object 'Dictionary
    Dim r As Long, c As Integer
    Dim i As Long, n As Long
    Dim s As String
    
    Set Ws = Sheets(1) 'data Sheet
    Set toWs = Sheets(2) 'Result Sheet
    
    Set DicR = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary
    Set DicC = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary
    
    vDB = Ws.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    
    ReDim vR(1 To r, 1 To 100)
    
    For i = 2 To r
        s = vDB(i, 1)
        If DicC.Exists(s) Then
            DicC(s) = DicC(s) + 1
        Else
            n = n + 1
            DicR.Add s, n 'row index
            DicC.Add s, 2 'column index
        End If
        vR(n, 1) = s
        vR(DicR(s), DicC(s)) = vDB(i, 2)
    Next i
    
    c = WorksheetFunction.Max(DicC.Items)
    
    ReDim Preserve vR(1 To r, 1 To c)
    With toWs
        .UsedRange.Clear
        .Range("a1").Resize(r, c) = vR
    End With

End Sub

---

此代码还使用字典

Sub TransposeWeeks()
Dim rngDst As Range
Dim arrData()
Dim arrWeeks()
Dim dic As Object
Dim cnt As Long
Dim idx As Long
Dim ky As Variant

    arrData = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    
    Set rngDst = Sheets("Sheet2").Range("A1")
    Set dic = CreateObject("Scripting.Dictionary")
    
    For idx = LBound(arrData, 1) + 1 To UBound(arrData, 1)
        ky = arrData(idx, 1)
        
        If dic.Exists(ky) Then
            arrWeeks = dic(ky)
            cnt = UBound(arrWeeks) + 1
        Else
            cnt = 1
        End If
           
        ReDim Preserve arrWeeks(1 To cnt)
        
        arrWeeks(cnt) = arrData(idx, 2)
        dic(ky) = arrWeeks
    Next idx
    
    For Each ky In dic.keys
        rngDst = ky
        arrWeeks = dic(ky)
        rngDst.Offset(, 1).Resize(, UBound(arrWeeks)).Value = arrWeeks
        Set rngDst = rngDst.Offset(1)
    Next ky
    
End Sub

---

欢迎来到你的第一篇帖子。请为您尝试的内容添加vba代码，并解释哪些不起作用。另外，数据透视表不会排序吗？对于这两个数据集（实际和预期），都需要有一个包含所有周数的行，例如一个虚拟行。您也可以通过添加一个helper id列来处理公式，该列连接worker和week，并从预期表到实际表进行查找/匹配。