自习安排次数统计

quqiyuan · 发表于 2024-9-5 23:03

参与一下，仅供参考。。。

quqiyuan · 发表于 2024-9-5 23:03

代码如下。。。
Sub test()
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
Set sht = wb.Sheets("月汇总")
With sht
      brr = .Range("a4:i" & .Cells(6, "a").End(4).Row)
      brr(1, 8) = "培优班"
      x = .[k2]: y = [o2]
End With

ReDim br(x To y)
For i = x To y
      br(i) = i
Next

For i = 3 To UBound(brr)
      d(brr(i, 1)) = i
Next
For i = 2 To UBound(brr, 2)
      If brr(1, i) <> Empty Then dic(brr(1, i)) = i Else dic("管  理") = i
Next

ReDim crr(1 To UBound(brr) - 2, 1 To 8)

For Each num In br
      s = Application.Text(num, "[dbnum1]")
      On Error Resume Next
      Set sh = wb.Sheets("第" & s & "周")
      If Not sh Is Nothing Then
         On Error GoTo 0
         arr = sh.Range(sh.[a4], sh.Cells(sh.Cells(Rows.Count, 2).End(3).Row, "m"))
         For i = 2 To UBound(arr)
            If arr(i, 2) = Empty Then arr(i, 2) = arr(i - 1, 2)
         Next
         For i = 2 To UBound(arr, 2)
            If arr(1, i) = Empty Then arr(1, i) = arr(1, i - 1)
         Next
         For i = 3 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                  s = arr(i, j)
                  If d.exists(s) Then
                     If arr(i, 2) = "下午延时服务" Then
                        If dic.exists(arr(1, j)) Then
                              crr(d(s) - 2, dic(arr(1, j)) - 1) = crr(d(s) - 2, dic(arr(1, j)) - 1) + 1
                        Else
                              crr(d(s) - 2, 1) = crr(d(s) - 2, 1) + 1
                        End If
                     ElseIf arr(i, 2) = "晚3" Then
                        crr(d(s) - 2, 4) = crr(d(s) - 2, 4) + 1
                     Else
                        crr(d(s) - 2, 3) = crr(d(s) - 2, 3) + 1
                     End If
                     crr(d(s) - 2, 8) = "=sum(rc[-7]:rc[-1])"
                  End If
            Next
         Next
      End If
      Set sh = Nothing
Next
sht.[b6:i39] = Empty
sht.[b6].Resize(UBound(crr), 8) = crr
Set d = Nothing
Set dic = Nothing
Beep
End Sub

quqiyuan · 发表于 2024-9-6 07:44

刚调整了下，超过十周以上也可以。。。

quqiyuan · 发表于 2024-9-6 07:45

代码如下。。。
Sub test()
Dim sh As Worksheet
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
Set sht = wb.Sheets("月汇总")
With sht
      brr = .Range("a4:i" & .Cells(6, "a").End(4).Row)
      brr(1, 8) = "培优班"
      x = .[k2]: y = .[o2]
End With

ReDim br(x To y)
For i = x To y
      br(i) = i
Next

For i = 3 To UBound(brr)
      d(brr(i, 1)) = i
Next
For i = 2 To UBound(brr, 2)
      If brr(1, i) <> Empty Then dic(brr(1, i)) = i Else dic("管  理") = i
Next

ReDim crr(1 To UBound(brr) - 2, 1 To 8)

For Each num In br
      s = Application.Text(num, "[dbnum1]")
      If Len(s) > 1 Then s = Mid(s, 2)
      On Error Resume Next
      Set sh = wb.Sheets("第" & s & "周")
      If Not sh Is Nothing Then
         On Error GoTo 0
         arr = sh.Range(sh.[a4], sh.Cells(sh.Cells(Rows.Count, 2).End(3).Row, "m"))
         For i = 2 To UBound(arr)
            If arr(i, 2) = Empty Then arr(i, 2) = arr(i - 1, 2)
         Next
         For i = 2 To UBound(arr, 2)
            If arr(1, i) = Empty Then arr(1, i) = arr(1, i - 1)
         Next
         For i = 3 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                  s = arr(i, j)
                  If d.exists(s) Then
                     If arr(i, 2) = "下午延时服务" Then
                        If dic.exists(arr(1, j)) Then
                              crr(d(s) - 2, dic(arr(1, j)) - 1) = crr(d(s) - 2, dic(arr(1, j)) - 1) + 1
                        Else
                              crr(d(s) - 2, 1) = crr(d(s) - 2, 1) + 1
                        End If
                     ElseIf arr(i, 2) = "晚3" Then
                        crr(d(s) - 2, 4) = crr(d(s) - 2, 4) + 1
                     Else
                        crr(d(s) - 2, 3) = crr(d(s) - 2, 3) + 1
                     End If
                     crr(d(s) - 2, 8) = "=sum(rc[-7]:rc[-1])"
                  End If
            Next
         Next
      End If
      Set sh = Nothing
Next
sht.[b6:i39] = Empty
sht.[b6].Resize(UBound(crr), 8) = crr
Set d = Nothing
Set dic = Nothing
Beep
End Sub

阿Jk · 发表于 2024-9-6 10:04

本帖最后由阿Jk 于 2024-9-6 11:16 编辑

不好意思，因为要在月汇总第一列增加序号，麻烦老师再帮我改一下

quqiyuan · 发表于 2024-9-6 11:10

阿Jk 发表于 2024-9-6 10:04
不好意思，因为要在月汇总第一列增加序号，麻烦老师再帮我改一下

代码优化了一下

quqiyuan · 发表于 2024-9-6 11:11

代码如下。。。
Sub test()  '加了序号的
Dim sh As Worksheet
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
Set sht = wb.Sheets("月汇总")
With sht
      brr = .Range("a4:j" & .Cells(6, "b").End(4).Row)
      brr(1, 9) = "培优班"
      x = .[k2]: y = .[o2]
End With
If Not IsNumeric(x) Or Not IsNumeric(y) Then MsgBox "输入周数的数字有误，请核实，退出！！": Exit Sub
If y - x < 0 Then MsgBox "输入周数的数字有误，请核实，退出！！": Exit Sub
ReDim br(x To y)
For i = x To y
      br(i) = i
Next

For i = 3 To UBound(brr)
      If brr(i, 2) <> Empty Then d(brr(i, 2)) = i
Next
For i = 3 To UBound(brr, 2)
      If brr(1, i) <> Empty Then dic(brr(1, i)) = i - 1 Else dic("管  理") = i - 1 '插入多一列，不改下面代码，这里减1
Next

ReDim crr(1 To UBound(brr) - 2, 1 To 8)

For Each num In br
      s = Application.Text(num, "[dbnum1]")    '这个其实工作表名称是数字就不用转换那么麻烦
      If Len(s) > 1 And Left(s, 1) = "一" Then s = Mid(s, 2)
      On Error Resume Next
      Set sh = wb.Sheets("第" & s & "周")
      If Not sh Is Nothing Then
         On Error GoTo 0
         arr = sh.Range(sh.[a4], sh.Cells(sh.Cells(Rows.Count, 2).End(3).Row, "m"))
         For i = 2 To UBound(arr)
            If arr(i, 2) = Empty Then arr(i, 2) = arr(i - 1, 2)
         Next
         For i = 2 To UBound(arr, 2)
            If arr(1, i) = Empty Then arr(1, i) = arr(1, i - 1)
         Next
         For i = 3 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                  s = arr(i, j)
                  If d.exists(s) Then
                     If arr(i, 2) = "下午延时服务" Then
                        If dic.exists(arr(1, j)) Then
                              crr(d(s) - 2, dic(arr(1, j)) - 1) = crr(d(s) - 2, dic(arr(1, j)) - 1) + 1
                        Else
                              crr(d(s) - 2, 1) = crr(d(s) - 2, 1) + 1
                        End If
                     ElseIf arr(i, 2) = "晚3" Then
                        crr(d(s) - 2, 4) = crr(d(s) - 2, 4) + 1
                     Else
                        crr(d(s) - 2, 3) = crr(d(s) - 2, 3) + 1
                     End If
                     crr(d(s) - 2, 8) = "=sum(rc[-7]:rc[-1])"
                  End If
            Next
         Next
      End If
      Set sh = Nothing
Next
sht.[c6:j39] = Empty
sht.[c6].Resize(UBound(crr), 8) = crr
Set d = Nothing
Set dic = Nothing
Beep
End Sub

阿Jk · 发表于 2024-9-14 15:35

本帖最后由阿Jk 于 2024-9-14 15:38 编辑

表格做了些简化，统计时，最后一栏的数据不能汇总，老师，麻烦再帮我看一下

quqiyuan · 发表于 2024-9-14 16:56

本帖最后由 quqiyuan 于 2024-9-14 17:03 编辑

阿Jk 发表于 2024-9-14 15:35
表格做了些简化，统计时，最后一栏的数据不能汇总，老师，麻烦再帮我看一下

这样简单了很多，修改的也多了，仅供参考。。。

quqiyuan · 发表于 2024-9-14 16:57

本帖最后由 quqiyuan 于 2024-9-14 17:03 编辑

阿Jk 发表于 2024-9-14 15:35
表格做了些简化，统计时，最后一栏的数据不能汇总，老师，麻烦再帮我看一下

这样简单了很多，修改的也多了，仅供参考。。。

Sub 月汇总()  '加了序号的
Dim sh As Worksheet
Set d = CreateObject("scripting.dictionary")
Set wb = ThisWorkbook
Set sht = wb.Sheets("月汇总")
With sht
      brr = .Range("a4:k" & .Cells(6, "b").End(4).Row)
      x = .[d2]: y = .[k2]
End With
If Not IsNumeric(x) Or Not IsNumeric(y) Then MsgBox "输入周数的数字有误，请核实，退出！！": Exit Sub
If y - x < 0 Then MsgBox "输入周数的数字有误，请核实，退出！！": Exit Sub
ReDim br(x To y)
For i = x To y
      br(i) = i
Next
For i = 3 To UBound(brr)
      If brr(i, 2) <> Empty Then d(brr(i, 2)) = i
Next
ReDim crr(1 To UBound(brr) - 2, 1 To 9)

For Each num In br
      s = Application.Text(num, "[dbnum1]")    '这个其实工作表名称是数字就不用转换那么麻烦
      If Len(s) > 1 And Left(s, 1) = "一" Then s = Mid(s, 2)
      On Error Resume Next
      Set sh = wb.Sheets("第" & s & "周")
      If Not sh Is Nothing Then
         On Error GoTo 0
         arr = sh.Range(sh.[a4], sh.Cells(sh.UsedRange.Rows.Count, "m"))
         For i = 3 To UBound(arr)
            For j = 3 To UBound(arr, 2)
                  s = arr(i, j)
                  If d.exists(s) Then
                     If arr(1, j) <> "管  理" Then
                        crr(d(s) - 2, 1) = crr(d(s) - 2, 1) + 1
                     Else
                        crr(d(s) - 2, 2) = crr(d(s) - 2, 2) + 1
                     End If
                     crr(d(s) - 2, 8) = "=sum(rc[-7]:rc[-1])"
                     crr(d(s) - 2, 9) = "=sumproduct(rc[-1]*50)"
                  End If
            Next
         Next
      End If
      Set sh = Nothing
Next
sht.[c6:k24] = Empty
sht.[c6].Resize(UBound(crr), 9) = crr
Set d = Nothing
Beep
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 自习安排次数统计

评分

评分

评分

评分

评分

评分

评分

评分