Question

我在这个网站上发现了一些非常有用的代码： -

Public Sub Example()
    Dim rng As Range
    Dim tmpArr As Variant
    Dim Dict As Object, tmpDict As Object
    Dim i As Long, j As Long
    Dim v, key
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set Dict = CreateObject("Scripting.Dictionary")
    Set ws = Worksheets("Data")
    Set ws1 = Worksheets("Output")

    ' Update to your sheet here
    With ws
        ' You may need to modify this depending on where you range is stored
        Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))

        tmpArr = rng.Value

        For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
            ' Test if value exists in dictionary. If not add and set up the dictionary item
            If Not Dict.exists(tmpArr(i, 1)) Then
                Set tmpDict = Nothing
                Set tmpDict = CreateObject("Scripting.Dictionary")
                Dict.Add key:=tmpArr(i, 1), Item:=tmpDict
            End If
            ' Set nested dictionary to variable so we can edit it
            Set tmpDict = Nothing
            Set tmpDict = Dict(tmpArr(i, 1))

            ' Test if value exists in nested Dictionary, add if not and initiate counter
            If Not tmpDict.exists(tmpArr(i, 2)) Then
                tmpDict.Add key:=tmpArr(i, 2), Item:=1
            Else
                ' Increment counter if it already exists
                tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1
            End If
            ' Write nested Dictionary back to Main dictionary
            Set Dict(tmpArr(i, 1)) = tmpDict
        Next i

        ' Repurpose array for output setting to maximum possible size (helps with speed of code)
        ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1))
        ' Set starting counters for array
        i = LBound(tmpArr, 1)
        j = LBound(tmpArr, 2)
        ' Convert dictionary and nested dictionary to flat output
        For Each key In Dict
            tmpArr(j, i) = key
            i = i + 1
            For Each v In Dict(key)
                tmpArr(j, i) = v
                tmpArr(j + 1, i) = Dict(key)(v)
                i = i + 1
            Next v
        Next key
        ' Reshape array to actual size
        ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1)
        ' Change this to the starting cell of your output
        With ws1.Cells(2, 5)

            Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr)
        End With
    End With
End Sub

总结了以下数据

Code    Tbk Mnth
C7  01-Apr-12
PP  01-Mar-18
PP  01-Jan-18
BK  01-Feb-17
FB  01-Feb-17
B9  01-Jan-17
B2  01-Mar-17

像这样

A&  
2018/05/01  1
A1  
2016/08/01  1
2016/12/01  1
2018/01/01  1
2018/02/01  95
2018/03/01  418
2018/04/01  351
2018/05/01  41
2018/06/01  746
2018/07/01  2
A4  
2018/06/01  1
2018/07/01  1
AH  
2017/03/01  34
2017/12/01  3
2018/01/01  9
2018/02/01  43
2018/03/01  136
2018/04/01  1
2018/05/01  1

如何改变它以使它看起来像这样： -

        2016/08/01  2016/12/01  2018/01/01  2018/02/01  2018/03/01  2018/04/01  2018/05/01  2018/06/01  2018/07/01
A1      1   1   1   95  418 351 41  746 2

Answer 1

创建两个独特日期和代码的字典（其中值只是递增数字） - 然后在循环数据时使用这些字典，将数字字典值提供给Offset（）以识别网格中的正确单元格增加那里的值

Sub Pivot()

    Dim rngData As Range, dDate, dCode, rw As Range, rOff As Long, cOff As Long
    Dim shtP As Worksheet

    Set shtP = Sheets("Pivot")

    With Sheets("Data")
        Set rngData = .Range(.Cells(2, 1), _
                             .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
    End With

    Set dDate = UniquesAndOrderFromRange(rngData.Columns(1))
    Set dCode = UniquesAndOrderFromRange(rngData.Columns(2))

    shtP.UsedRange.Clear
    shtP.Range("B3").Resize(dCode.Count, 1).Value = Application.Transpose(dCode.keys)
    shtP.Range("C2").Resize(1, dDate.Count).Value = dDate.keys


    For Each rw In rngData.Rows
        rOff = dCode(rw.Cells(2).Value)
        cOff = dDate(rw.Cells(1).Value)
        With shtP.Range("B2").Offset(rOff, cOff)
            Debug.Print rw.Cells(2).Value, rOff, rw.Cells(1).Value, cOff
            .Value = .Value + 1
        End With
    Next rw

End Sub


Property Get UniquesAndOrderFromRange(rng As Range)
    Dim c As Range, i As Integer, tmp, d
    Set d = CreateObject("Scripting.Dictionary")
    i = 0
    For Each c In rng.Cells
       tmp = c.Value
       If Len(tmp) > 0 Then
            If Not d.Exists(tmp) Then
                 i = i + 1
                 d.Add tmp, i
            End If
       End If
    Next c
    Set UniquesAndOrderFromRange = d
End Property

如何更改数组中的数据的方式显示在工作表中

1 个答案: