分行分列，提取不了数据，谢谢四位老师！

lhj323323

liulang0808 发表于 2024-1-26 10:16
新增加那三列，不知道什么逻辑
之前不输出结果部分，做了需改

新增的三列，

其中M和N列里的【今年】是个动态概念，不是特指2024年
而是数据源A列里的【最大年】
而O列，则是A列里的所有年份。

lhj323323

liulang0808 发表于 2024-1-26 10:16
新增加那三列，不知道什么逻辑
之前不输出结果部分，做了需改

老师：

4楼的语句，没有考虑C列的STR

lhj323323

ykcbf1100 发表于 2024-1-26 11:25
那改一下吧。

老师

Max = IIf(Max < s, s, Max)
这句要报错，说的是Max变量未定义

ykcbf1100

lhj323323 发表于 2024-1-26 12:53
老师

Max = IIf(Max < s, s, Max)

加一句吧，我这里是没问题的。

lhj323323

cidanji 发表于 2024-1-26 11:37
我觉得有个歧义的地方，后面绿色的每年统计，是仅STR还是所有标识

老师：
是仅STR

lhj323323

yynrzwh 发表于 2024-1-26 11:31
猜的

老师：
导出的结果表，没有对：
没有第一列。

MNO三列，
应为每支股票自身的合计
而不是所有股票的合计。

lhj323323

ykcbf1100 发表于 2024-1-26 12:54
加一句吧，我这里是没问题的。

这会不会是2003版本的原因？

cidanji

lhj323323 发表于 2024-1-26 12:55
老师：
是仅STR

liulang0808

Sub test()
    Dim Arr, brr, d As Object, d1 As Object, dd
    Dim k, mx
    Dim i%, j%, m%, n%
    Dim s$, ss$
    Dim sm As Double
    Set d = CreateObject("Scripting.Dictionary")
    Set dd = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Dim yy
    yy = 0
   
With Sheet1
     Arr = .[a1].CurrentRegion

    ReDim brr(1 To UBound(Arr), 1 To 1000)
    For i = 2 To UBound(Arr) '
       If Arr(i, 3) = "STR" Then
            s = Left(Arr(i, 1), 4): ss = Arr(i, 2) & ""
            If Val(s) > yy Then yy = Val(s)
            If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
            If Not dd.exists(ss) Then
                Set dd(ss) = CreateObject("Scripting.Dictionary")
            End If
            If Not dd(ss).exists(s) Then
                Set dd(ss)(s) = CreateObject("Scripting.Dictionary")
            End If
            dd(ss)(s)(Val(Arr(i, 1))) = dd(ss)(s)(Val(Arr(i, 1))) + Arr(i, 4)
            zz = dd(ss)(s).keys
            d(s)(ss) = Arr(i, 4) + d(s)(ss)
            d1(ss) = ""
        End If
    Next
   
    ReDim brr(1 To UBound(Arr), 1 To 5000)
    m = 1: n = 1
    brr(1, 1) = "金额"
    For Each k In d.keys
        n = n + 1
        brr(1, n) = k
    Next
    For Each k In d1.keys
        m = m + 1
        brr(m, 1) = k
    Next
    On Error Resume Next
   
   '导入到结果表区域
    .[l1].Resize(m, n) = brr
        
    Arr = .[l1].Resize(m, n + 3)
    Arr(1, n + 1) = "今年最后一笔STR的金额"
    Arr(1, n + 2) = "今年所有STR的金额合计"
    Arr(1, n + 3) = "所有年份STR的金额合计"

    For i = 2 To UBound(Arr)
        
        For j = 2 To n
            ss = Arr(i, 1)
            s = Left(Arr(1, j), 4)
            Arr(i, j) = d(s)(ss)
        Next
        s = yy & ""
        ss = Arr(i, 1) & ""
        If dd(Arr(i, 1)).exsits(s) Then
            wrr = dd(ss)(s).keys
            mx = WorksheetFunction.Max(dd(ss)(s).keys)
            Arr(i, n + 1) = dd(ss)(s)(mx)
            Arr(i, n + 2) = WorksheetFunction.Sum(dd(ss)(s).items)
            sm = 0
            For Each k In dd(ss).keys
                sm = sm + WorksheetFunction.Sum(dd(ss)(k).items)
            Next k
            Arr(i, n + 3) = sm
        End If
        
    Next

    .[l1].Resize(m, n + 3) = Arr
End With

End Sub

liulang0808

求助.zip (37.67 KB, 下载次数: 7)

2024-1-26 13:33 上传

点击文件名下载附件

在原来的基础上添加的，有些混乱，供参考。。。。。