Excel中VBA统计每个人对应的列同时全为空出现的次数

ykcbf1100

yjwdjfqb 发表于 2024-3-18 15:24
老师你好，我用到我的附件中
结果没有正确
我修改了下，代码的

你用的并不是我的代码，搞这么复杂吗？

ykcbf1100

yjwdjfqb 发表于 2024-3-18 15:24
老师你好，我用到我的附件中
结果没有正确
我修改了下，代码的

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.18
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     b = [{5,7,9,12}]
   
6.     With Sheets("表二")
   
7.         r = .Cells(.Rows.Count, "g").End(xlUp).Row
   
8.         arr = .Range("g3:r" & r)
   
9.         For i = 2 To UBound(arr)
   
10.             s = arr(i, 2)
    
11.             If arr(i, 5) & arr(i, 7) & arr(i, 9) & arr(i, 12) = Empty Then
    
12.                 d(s) = d(s) + 1
    
13.             End If
    
14.         Next
    
15.     End With
    
16.     With Sheets("统计表二")
    
17.         .[r15].Resize(1000, 2) = ""
    
18.         .[r15].Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.Items))
    
19.         .[r15].Resize(d.Count, 2).Borders.LineStyle = 1
    
20.     End With
    
21.     Set d = Nothing
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

yjwdjfqb

ykcbf1100 发表于 2024-3-18 15:51
参与一下。。。

老师你好，非常感谢你的多次帮助
我改用到这个附件中，修改了
没有成功
老师可以，帮我在这个附件中修改下不
谢谢你了
由于数据涉及到人员个人信息，所以模拟了个数据，请老师多多包涵！！！
统计.rar (11.45 KB, 下载次数: 3)

2024-3-19 10:42 上传

点击文件名下载附件

fzxba

1. Sub test0()
   
2.   
   
3.   Dim Conn As Object, rs As Object, i As Integer
   
4.   Dim strConn As String, sql_ As String, SQL As String
   
5.   
   
6.   Set Conn = CreateObject("ADODB.Connection")
   
7.   'Set rs = CreateObject("ADODB.Recordset")
   
8.   
   
9.   If Application.Version < 12 Then
   
10.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;IMEX=1';Data Source="
    
11.   Else
    
12.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;IMEX=1';Data Source="
    
13.   End If
    
14.   Conn.Open strConn & ThisWorkbook.FullName
    
15.   
    
16.   sql_ = "SELECT FIRST(编号) AS 编号,FIRST(性别) AS 性别,NULL AS 测试,姓名,FIRST(满意度) AS 满意度 FROM [表一$F8:P] WHERE 姓名 IS NOT NULL GROUP BY 姓名"
    
17.   
    
18.   SQL = "SELECT 姓名,(LEN(衣服&'')=0)+(LEN(围巾销量&'')=0)+(LEN(衬衣&'')=0)+(LEN(其它收入&'')=0) AS KLNP同时为空 FROM [表一$F8:P] WHERE 姓名 IS NOT NULL"
    
19.   SQL = "SELECT 姓名,COUNT(KLNP同时为空) AS KLNP同时为空 FROM (SELECT * FROM (" & SQL & ") WHERE KLNP同时为空=-4) GROUP BY 姓名"
    
20.   SQL = "SELECT a.*,b.KLNP同时为空 FROM (" & sql_ & ") a LEFT JOIN (" & SQL & ") b ON a.姓名=b.姓名"
    
21.   
    
22.   Set rs = Conn.Execute(SQL)
    
23.   
    
24.   With Sheet2.Range("J11")
    
25.     .CurrentRegion.ClearContents
    
26.     For i = 0 To rs.Fields.Count - 1
    
27.       .Offset(, i) = rs.Fields(i).Name
    
28.     Next
    
29.     .Offset(1).CopyFromRecordset rs
    
30.   End With
    
31.   
    
32.   rs.Close
    
33.   Set rs = Nothing
    
34.   Conn.Close
    
35.   Set Conn = Nothing
    
36.   Beep
    
37. End Sub

复制代码

ykcbf1100

yjwdjfqb 发表于 2024-3-19 10:42
老师你好，非常感谢你的多次帮助
我改用到这个附件中，修改了
没有成功

写好了。。。

ykcbf1100

写法换了下。

1. Sub ykcbf()   '//2024.3.19
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     b = [{1,2,4,5,3}]
   
6.     m = 0
   
7.     With Sheets("表一")
   
8.         r = .Cells(.Rows.Count, "f").End(xlUp).Row
   
9.         arr = .Range("f8:p" & r)
   
10.         ReDim brr(1 To 1000, 1 To 6)
    
11.         For i = 2 To UBound(arr)
    
12.             s = arr(i, 5)
    
13.             If arr(i, 6) & arr(i, 7) & arr(i, 9) & arr(i, 11) = Empty Then
    
14.                 If Not d.exists(s) Then
    
15.                     m = m + 1
    
16.                     d(s) = m
    
17.                     brr(m, 1) = m
    
18.                     For j = 2 To UBound(b)
    
19.                         brr(m, j) = arr(i, b(j))
    
20.                     Next
    
21.                     brr(m, 6) = 1
    
22.                 Else
    
23.                     r = d(s)
    
24.                     brr(r, 6) = brr(r, 6) + 1
    
25.                 End If
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     With Sheets("表二")
    
30.         .[j8].Resize(1000, 6) = ""
    
31.         .[j8].Resize(m, 6) = brr
    
32.         .[j8].Resize(m, 6).Borders.LineStyle = 1
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

yjwdjfqb

gwjkkkkk 发表于 2024-3-16 19:58
参与一下。。。

老师你好，谢谢你的帮助
附件中
王莹，人员，指定列，全为空的记录，只有二次
代码执行结果，三次
麻烦老师帮修改下好吧，非常感谢老师！！！