20170814xlVBA部分代号收盘价转置

原始数据：

转置效果：

 

 

Sub TransformData()
    Dim Rng As Range
    Dim Arr As Variant
    Dim Dic As Object
    Dim dCode As Object
    Dim dDay As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Set dCode = CreateObject("Scripting.Dictionary")
    Set dDay = CreateObject("Scripting.Dictionary")
    With Sheets("WRESSTK")
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:C" & endrow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            
            Key = Format(Arr(i, 1), "000000")
            dCode(Key) = ""
            
            Key = Format(Arr(i, 2), "yyyy-mm-dd")
            dDay(Key) = ""
            
            Key = Format(Arr(i, 1), "000000") & ";" & Format(Arr(i, 2), "yyyy-mm-dd")
            Dic(Key) = Arr(i, 3)
        Next i
    End With
    
    With Sheets("Result")
        i = 1
        For Each k In dCode.keys
            i = i + 1
            .Cells(i, 1).Value = "'" & k
        Next k
        
        j = 1
        For Each k In dDay.keys
            j = j + 1
            .Cells(1, j).Value = "'" & k
        Next k
        'Exit Sub
        For m = 2 To i
            For n = 2 To j
                Key = Format(.Cells(m, 1).Text) & ";" & Format(.Cells(1, n).Text, "yyyy-mm-dd")
                .Cells(m, n).Value = Dic(Key)
            Next n
        Next m
    End With
    
    Set Dic = Nothing
    Set dCode = Nothing
    Set dDay = Nothing
    Set Rng = Nothing
End Sub