明细汇总问题

·遁去的一·

公司下属有N个部门，各部门每月上报工作报表，我想要将各部门上报的月报汇总成一个横表，具体效果在表格里，请各位兄弟帮助解决

ykcbf1100

你分表中科室名都没有一个的，让我们造一个上去？不合适吧

ykcbf1100

还是发一个吧

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.3.21
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("全镇汇总表")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 15)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xlsx" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 m = m + 1
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 With wb.Sheets("科室上报表")
    
13.                     arr = .UsedRange
    
14.                     wb.Close False
    
15.                 End With
    
16.                 brr(m, 1) = m
    
17.                 brr(m, 2) = Split(arr(2, 1), ":")(1)
    
18.                 brr(m, 3) = arr(4, 2)
    
19.                 brr(m, 4) = arr(5, 2)
    
20.                 brr(m, 5) = arr(9, 2)
    
21.                 brr(m, 6) = arr(10, 2)
    
22.                 brr(m, 7) = brr(m, 6) + brr(m, 3) + brr(m, 4) + brr(m, 5)
    
23.                 brr(m, 8) = arr(4, 4)
    
24.                 brr(m, 9) = arr(5, 4)
    
25.                 brr(m, 10) = arr(6, 4)
    
26.                 brr(m, 11) = arr(7, 4)
    
27.                 brr(m, 12) = arr(9, 4)
    
28.                 brr(m, 13) = arr(10, 4)
    
29.                 brr(m, 14) = arr(11, 4)
    
30.                 brr(m, 15) = f.Name
    
31.             End If
    
32.         End If
    
33.     Next f
    
34.     With sh
    
35.         .UsedRange.Offset(4) = ""
    
36.         .[a5].Resize(m, 15) = brr
    
37.         r = .Cells(Rows.Count, 1).End(3).Row
    
38.         r = r + 1
    
39.         .Cells(r, 1) = m + 1
    
40.         .Cells(r, 2) = "合计"
    
41.         .Cells(r, 3).Resize(1, 12).FormulaR1C1 = "=SUM(R5C:R" & "[-1]C)"
    
42.         .[a5].Resize(m, 14).Borders.LineStyle = 1
    
43.     End With
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub
    
47. 
    

复制代码

fzxba

1. Sub test0() '
   
2.   
   
3.   Dim p As String
   
4. '  With Application.FileDialog(msoFileDialogFolderPicker)
   
5. '    .InitialFileName = ThisWorkbook.Path
   
6. '    If .Show Then p = .SelectedItems(1) Else Exit Sub
   
7. '  End With
   
8. '  If Right(p, 1) <> "\" Then p = p & "\"
   
9.   p = ThisWorkbook.Path & "\"
   
10.   
    
11.   Dim s As String, f As String, strConn As String, SQL As String
    
12.   Dim i As Long, j As Long, k As Long, pos As Long
    
13.   
    
14.   s = "Excel 12.0;HDR=NO;Database="
    
15.   If Application.Version < 12 Then
    
16.     s = Replace(s, "12.0", "8.0")
    
17.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
    
18.   Else
    
19.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    
20.   End If
    
21.   
    
22.   f = Dir(p & "*.xls?")
    
23.   While Len(f)
    
24.     If p & f <> ThisWorkbook.FullName Then
    
25.       k = k + 1
    
26.       SQL = SQL & " UNION ALL SELECT '" & Split(f, ".xls")(0) & "',* FROM [" & s & p & f & "].[$A4:D] WHERE F3 IS NOT NULL"
    
27.     End If
    
28.     f = Dir
    
29.   Wend
    
30.   If k = 0 Then Exit Sub
    
31. '  DoApp False
    
32.   Dim ar, br, Conn As Object, dict As Object
    
33.   Set dict = CreateObject("Scripting.Dictionary")
    
34.   Set Conn = CreateObject("ADODB.Connection")
    
35.   
    
36.   With Worksheets("全镇汇总表")
    
37.     .Activate
    
38.     With .Range("A1").CurrentRegion
    
39.       .Offset(4).ClearContents
    
40.       ar = .Resize(49, 14).Value
    
41.     End With
    
42.   End With
    
43.   
    
44.   k = 4
    
45.   For j = 3 To UBound(ar, 2)
    
46.     If Len(ar(k, j)) Then s = ar(k, j) Else s = ar(k - 1, j)
    
47.     dict.Add Replace(s, Chr(10), ""), j
    
48.   Next
    
49.   s = vbNullString
    
50.   
    
51.   Conn.Open strConn & ThisWorkbook.FullName
    
52.   br = Conn.Execute(Mid(SQL, 12)).GetRows
    
53.   
    
54.   For j = 0 To UBound(br, 2)
    
55.     If br(0, j) <> s Then
    
56.       s = br(0, j)
    
57.       k = k + 1
    
58.       ar(k, 1) = k - 4
    
59.       ar(k, 2) = s
    
60.     End If
    
61.     For i = 1 To UBound(br) Step 2
    
62.       If Not IsNull(br(i, j)) Then If dict.Exists(br(i, j)) Then ar(k, dict(br(i, j))) = br(i + 1, j)
    
63.   Next i, j
    
64.   
    
65.   k = k + 1
    
66.   For i = 5 To k - 1
    
67.     For j = UBound(ar, 2) - 2 To UBound(ar, 2) - 1
    
68.       ar(k, j) = ar(k, j) + Val(ar(i, j))
    
69.       ar(k, UBound(ar, 2)) = ar(k, UBound(ar, 2)) + Val(ar(i, j))
    
70.   Next j, i
    
71.   ar(k, 1) = k - 4
    
72.   ar(k, 2) = "合计"
    
73.   
    
74.   Range("A1").Resize(k, UBound(ar, 2)) = ar
    
75.   
    
76.   Conn.Close
    
77.   Set Conn = Nothing
    
78.   Set dict = Nothing
    
79. '  DoApp
    
80.   Beep
    
81. End Sub

复制代码

fzxba

明细汇总.zip (225.31 KB, 下载次数: 23)

2024-3-21 19:12 上传

点击文件名下载附件

·遁去的一·

ykcbf1100 发表于 2024-3-21 10:03
还是发一个吧

附件供参考。。。

谢谢大佬的无私帮助

·遁去的一·

fzxba 发表于 2024-3-21 19:12

感谢付出，论坛因你而精彩