从sheet6 A列找出相同日期,以日期做为笔数

cmo9020

test.rar (16.12 KB, 下载次数: 5)

2023-2-23 23:23 上传

点击文件名下载附件

请问各位专业的导师
A1单元格是年
B1单元格是月
下拉选项后日期会变动
我要从sheet6 A列找出相同日期,然后以日期做为笔数
把笔数做累计加总在反黄色的区域

只要A1单元格或B1单元格和日有做变动,就会自动秀出每日的几笔笔数
像橘色部份为答案
请问要如何修改代码？麻烦请导师们指导一下,谢谢



Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$1" Or Target.Address = "$B$1" Then
Dim row As Integer
For row = 3 To 13
    If row Mod 2 = 1 Then
        If row <> 3 And row <> 5 And row <> 7 And row <> 9 And row <> 11 And row <> 13 Then
            Range("C" & row & ":I" & row).ClearContents
        Else
            Range("C" & row & ":I" & row).Clear
        End If
    End If
Next row

        Dim FirstDay As Date
        FirstDay = DateSerial(Val(Range("A1").Value), Val(Range("B1").Value), 1)
        Dim i As Integer
        For i = 0 To 6
        Next i
        Dim j As Integer
        Dim CurrentDate As Date
        CurrentDate = FirstDay
        For j = 0 To 5
            For i = 0 To 6
                If i = Weekday(CurrentDate, vbSunday) - 1 And month(CurrentDate) = Val(Range("B1").Value) Then
                    Cells(j * 2 + 3, i + 3) = Day(CurrentDate)
                    CurrentDate = CurrentDate + 1
                End If
            Next i
        Next j
    End If
End Sub

liulang0808

Private Sub Worksheet_Change(ByVal Target As Range)
    Set dd = CreateObject("scripting.dictionary")
    If Target.Address = "$A$1" Or Target.Address = "$B$1" Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        ym = [a1] & "-" & Val([b1])
        arr = Sheets(1).UsedRange
        For j = 2 To UBound(arr)
            If Format(arr(j, 1), "yyyy-m") = ym Then
                dd(Day(arr(j, 1))) = 1 + dd(Day(arr(j, 1)))
            End If
        Next j
        [c3:i14].ClearContents
        If Val([b1]) = 12 Then
            d = 31
        Else
            d = Day(CDate([a1] & "-" & Val([b1]) + 1 & "-1") - 1)
        End If
        r = 3
        For j = 1 To d
            dt = CDate(ym & "-" & j)
            c = Weekday(dt, vbSunday)
            If c = 1 Then
                r = r + 2
            End If
            Cells(r, c + 2) = Day(dt)
            If dd.exists(Day(dt)) Then Cells(r + 1, c + 2) = dd(Day(dt))
        Next
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

liulang0808

不知道理解对不对，供参考。。。。

cmo9020

liulang0808 发表于 2023-2-24 08:18
不知道理解对不对，供参考。。。。

没错,就是这样子,谢谢导师帮忙~非常谢谢