汇总符合条件的数据

taizhoexcelhome

依据条件进行数据汇总！请看附件。

longwin

怎么定义是当月？怎么定义是当月第几周？

taizhoexcelhome

longwin 发表于 2024-9-28 11:56
怎么定义是当月？怎么定义是当月第几周？

当月就是指以现在时间为当月，当月的第几周，一般一周按照7天周期来计算。

longwin

Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("b").Range("A2:K" & Sheets("b").[a1].End(xlDown).Row)
    brr = Sheets("a").Range("b2:AK" & Sheets("a").[b1].End(xlDown).Row)
    For i = 1 To UBound(arr)
        rq = CDate(arr(i, 1))
        kh = arr(i, 4)
        bm = arr(i, 6)
        sl = arr(i, 11)
        If Year(rq) = Year(Now) And Month(rq) = Month(Now) Then
            zhou = Int((Day(rq) - 1) / 7) + 1  '算第几周
            zh = kh & "|" & bm & "|" & zhou
            d(zh) = d(zh) + sl
        End If
    Next
   
    For i = 1 To UBound(brr)
        For wk = 1 To 3
            zh = brr(i, 1) & "|" & brr(i, 4) & "|" & wk
            If d.exists(zh) Then
                brr(i, 21 + 5 * wk) = d(zh)
            Else
                brr(i, 21 + 5 * wk) = 0
            End If
        Next
    Next
    Sheets("a").Range("b2:AK" & Sheets("a").[b1].End(xlDown).Row) = brr
    Set d = Nothing
End Sub

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet2.UsedRange.Value
   
5. For i = 2 To UBound(arr)
   
6.     Z = (Day(CDate(arr(i, 1))) - 0.9) / 7
   
7.     Z = Application.WorksheetFunction.RoundUp(Z, 0)
   
8.    
   
9.     s = arr(i, 4) & "|" & arr(i, 6) & "|" & Z
   
10.     If Not dic.exists(s) Then
    
11.         dic(s) = arr(i, 11)
    
12.     Else
    
13.         dic(s) = dic(s) + arr(i, 11)
    
14.     End If
    
15. Next
    
16. brr = Sheet1.Range("b2:ak" & Sheet1.Cells(Rows.Count, 2).End(3).Row)
    
17.     For i = 1 To UBound(brr)
    
18.         s = brr(i, 1) & "|" & brr(i, 4)
    
19.         If dic.exists(s & "|" & "1") Then brr(i, 26) = dic(s & "|" & "1")
    
20.         If dic.exists(s & "|" & "2") Then brr(i, 31) = dic(s & "|" & "2")
    
21.         If dic.exists(s & "|" & "3") Then brr(i, 36) = dic(s & "|" & "3")
    
22.     Next
    
23. 
    
24. Sheet1.Range("b2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
25. Set dic = Nothing
    
26. End Sub

复制代码

Qs18

试试。。。。。。。。。。。

Qs18

试试。。。。。