大家好，请教能不能统计出学号和座位号并改颜色，谢谢！

gzminge

1，统计学员每天学习需求，今天出现教室听课的学生号，如果明天继续听课，就把学号单元格涂成红色。然后旁边把座位号统计出来。

2，统计学员如果隔1天继续听课（不用管是否连续几天，这里只统计隔1天），就把学号单元格涂成红色。然后旁边把座位号统计出来。

3，如果学员隔2天，或者3天、4天来听课，又如何改？

谢谢大家，祝劳动节快乐！



99 20.zip (20.33 KB, 下载次数: 4)

2024-5-1 11:22 上传

点击文件名下载附件

chxw68

1. Sub 每天()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("每天")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("c3:v" & r)
   
9.         .Range("c3:v" & r).Interior.Color = 16772537
   
10.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
11.         For i = UBound(arr) To 2 Step -1
    
12.             d.RemoveAll
    
13.             For j = 1 To UBound(arr, 2)
    
14.                 d(arr(i, j)) = Empty
    
15.             Next
    
16.             n = 0
    
17.             For j = 1 To UBound(arr, 2)
    
18.                 If d.exists(arr(i - 1, j)) Then
    
19.                     .Cells(i - 1 + 2, j + 2).Interior.ColorIndex = 3
    
20.                     n = n + 1
    
21.                     brr(i - 1, n) = arr(i - 1, j)
    
22.                 End If
    
23.             Next
    
24.         Next
    
25.         .Range("x3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
26.     End With
    
27. End Sub
    

复制代码

chxw68

只写了次日的。

gzminge

chxw68 发表于 2024-5-1 11:41
只写了次日的。

谢谢老师！如果日期增加，并且隔2天3天，怎么修改呢？

gzminge

chxw68 发表于 2024-5-1 11:41
只写了次日的。

谢谢老师！如果日期增加，并且隔2天3天，甚至隔更多天，下面这里怎么修改呢？

Sub 每天()
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("每天")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("c3:v" & r)
        .Range("c3:v" & r).Interior.Color = 16772537
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For i = UBound(arr) To 2 Step -1
            d.RemoveAll
            For j = 1 To UBound(arr, 2)
                d(arr(i, j)) = Empty
            Next
            n = 0
            For j = 1 To UBound(arr, 2)
                If d.exists(arr(i - 1, j)) Then
                    .Cells(i - 1 + 2, j + 2).Interior.ColorIndex = 3
                    n = n + 1
                    brr(i - 1, n) = j
                End If
            Next
        Next
        .Range("x3").Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
End Sub

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, n&, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    For Each wks In Worksheets
        With wks
            With Range(.[C2], .Cells(Rows.Count, "V").End(xlUp))
                ar = .Value
                ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
                br(1, 1) = "座位号编号"
                For i = 2 To UBound(ar)
                    n = 0
                    For j = 1 To UBound(ar, 2)
                        If .Cells(i, j).Interior.Color = 5066944 Then
                            n = n + 1
                            br(i, n) = j
                        End If
                    Next j
                Next i
            End With
            .[X2].Resize(UBound(br), UBound(br, 2)) = br
        End With
    Next wks
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

chxw68

写了个通用的，随意输入间隔天数。

gzminge

gwjkkkkk 发表于 2024-5-1 12:08
请参考附件。。。

谢谢，鲜花已送上，祝劳动节快乐！

gzminge

chxw68 发表于 2024-5-1 12:09
写了个通用的，随意输入间隔天数。

谢谢，鲜花已送上，祝劳动节快乐！