我在这个网站上发现了一些非常有用的代码: -
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
答案 0 :(得分: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