求助vba遍历文件夹下所有excel文件汇总相应数据

jian82372387

求助用vba根据每天上班的班表，将每个人每天日期的班汇总，当天没有上班的就是休息，（汇总表里A列数据是整个车间的所有成员名单）

ykcbf1100

是这效果吧。

pjiang

ykcbf1100 发表于 2022-11-29 15:28
是这效果吧。

老师出手就是效率高，学习了

fzxba

1. Sub test1() '参与。
   
2.   Dim Conn As Object, rs As Object, Dict As Object
   
3.   Dim p As String, f As String, s As String
   
4.   Dim strConn As String, SQL As String, i As Integer
   
5.   
   
6.   Range("A1").CurrentRegion.ClearContents
   
7.   Application.ScreenUpdating = False
   
8. 
   
9.   Set Dict = CreateObject("Scripting.Dictionary")
   
10.   Set Conn = CreateObject("ADODB.Connection")
    
11.   
    
12.   s = "Excel 12.0;HDR=yes;IMEX=1;Database="
    
13.   If Application.Version < 12 Then
    
14.     s = Replace(s, "12.0", "8.0")
    
15.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source="
    
16.   Else
    
17.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source="
    
18.   End If
    
19.   Conn.Open strConn & ThisWorkbook.FullName
    
20.   
    
21.   p = ThisWorkbook.Path & "\"
    
22.   f = Dir(p & "*.xls?")
    
23.   SQL = "SELECT '[MD]' AS 日期,师傅 AS 名单,班号 FROM [" & s & p & "[f]].[$A2:C] WHERE LEN(师傅) UNION ALL " & _
    
24.         "SELECT '[MD]' AS 日期,学徒 AS 名单,班号 FROM [" & s & p & "[f]].[$A2:C] WHERE LEN(学徒)"
    
25.   Do
    
26.     If p & f <> ThisWorkbook.FullName Then
    
27.       Dict.Add Replace(Replace(SQL, "[MD]", Split(f, ".xls")(0)), "[f]", f), vbNullString
    
28.     End If
    
29.     f = Dir
    
30.   Loop While Len(f)
    
31.   
    
32.   If Dict.Count Then
    
33.     SQL = "TRANSFORM MAX(班号) SELECT 名单 FROM (" & Join(Dict.Keys, " UNION ALL ") & ") GROUP BY 名单 PIVOT 日期"
    
34.     Set rs = Conn.Execute(SQL)
    
35.     With Range("A1")
    
36.       For i = 0 To rs.Fields.Count - 1
    
37.         .Offset(0, i) = rs.Fields(i).Name
    
38.       Next
    
39.       .Offset(1).CopyFromRecordset rs
    
40.       .CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = "休息"
    
41.     End With
    
42.   End If
    
43.   
    
44.   Set rs = Nothing
    
45.   Conn.Close
    
46.   Set Conn = Nothing
    
47.   Set Dict = Nothing
    
48.   Application.ScreenUpdating = True
    
49.   Beep
    
50. End Sub

复制代码

fzxba

test.rar (35.53 KB, 下载次数: 10)

2022-11-29 16:57 上传

点击文件名下载附件

jian82372387

ykcbf1100 发表于 2022-11-29 15:28
是这效果吧。

运行调试显示这一句有问题
.[a2].Resize(m, 1) = brr

ykcbf1100

jian82372387 发表于 2022-11-29 20:11
运行调试显示这一句有问题
.[a2].Resize(m, 1) = brr

出现错误提示，有可能是m值为0。

用这个吧。

菌要橙死

请参考附件

jian82372387

ykcbf1100 发表于 2022-11-30 09:17
出现错误提示，有可能是m值为0。

用这个吧。

有办法我汇总表的A列名单是固定的（系统导出来全生产车间的名字），只是需要查找相对应人员的班号，因为按这种办法名字会很乱，不方便导入另外一个表里（代码有些复杂，看不太懂，顺便想请教一下如果需遍历的表格里面人名放在E和F列而不是B和C列需修改哪个参数啊）
是这几句需要修改吗？？
For i = 4 To UBound(arr)
                For j = 2 To 3
                    s = arr(i, j) & "|" & CDate(fn)
                    If arr(i, j) <> Empty Then
                        d(s) = arr(i, 1)

ykcbf1100

jian82372387 发表于 2022-11-30 12:27
有办法我汇总表的A列名单是固定的（系统导出来全生产车间的名字），只是需要查找相对应人员的班号，因为 ...

这个地方改一下。