表格按年份分类，求公式。

金盛鼠

像下面图片一样的日期，只按年份将数据分类，还有的就是有新数据写入时同样会按年份归类，求公式。


已求到解答，答案在下面。

砂海

个人感觉这种思路 , 数据冗余 , 计算冗余 .

mytto88

Sub kk()
    Dim dic As Object, arr(), brr(), arrTemp(), arrCount()
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sht In Worksheets
        If sht.CodeName <> "Sheet1" Then
            sht.Delete
        End If
    Next
    With Sheet1
        arr = .Range("a1").CurrentRegion
        ReDim arrTemp(1 To UBound(arr), 1 To 7)
        For i = 2 To UBound(arr)
            x = Year(arr(i, 4))
            If dic.exists(x) = False Then
                n = n + 1
                dic(x) = n
                ReDim Preserve brr(1 To n)
                ReDim Preserve arrCount(1 To n)
                brr(n) = arrTemp
            End If
            k = dic(x)
            arrCount(k) = arrCount(k) + 1
            brr(k)(arrCount(k), 1) = arr(i, 1)
            brr(k)(arrCount(k), 2) = arr(i, 2)
            brr(k)(arrCount(k), 3) = arr(i, 3)
            brr(k)(arrCount(k), 4) = arr(i, 4)
            brr(k)(arrCount(k), 5) = arr(i, 5)
            brr(k)(arrCount(k), 6) = arr(i, 6)
            brr(k)(arrCount(k), 7) = arr(i, 7)
        Next i
    End With
        For i = 1 To n
            Set sht = Worksheets.Add(, Worksheets(Worksheets.Count))
            With sht
                Sheet1.Rows(1).Copy .Range("a1")
                .Range("C:C", "E:E").NumberFormatLocal = "@"
                 .Range("D:D").NumberFormatLocal = "yyyy/m/d"
                .Range("a2").Resize(arrCount(i), 7) = brr(i)
                .Range("a2").Resize(arrCount(i), 7).Columns.AutoFit
                .Range("a2").Resize(arrCount(i), 7).Borders.LineStyle = 1
                .Name = dic.keys()(i - 1)
            End With
        Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set dic = Nothing
End Sub

心正意诚身修

你筛选三次。。复制。粘贴 。总会吧。

金盛鼠

mytto88 发表于 2019-7-30 11:01
Sub kk()
    Dim dic As Object, arr(), brr(), arrTemp(), arrCount()
    Set dic = CreateObject("sc ...

非常感谢！用不了宏。

金盛鼠

已求到解答。

比如2017表公式
A2输入
=INDEX(Sheet1!A:A,SMALL(IF(YEAR(Sheet1!$D$2:$D$1000)=2017,ROW($2:$1000),4^8),ROW(A1)))&""
数组公式，先按住CTRL+SHIFT,最后回车，使得编辑栏公式两端出现花括号{ }
公式右拉再下拉到无数据,可多拉若干行，以便接收新增数据
表2018和表2019只要将公式中的2017改为2018,2019即可