对Excel工作薄中的多个工作表进行求和统计。

ynzsvt

自定义工具栏加了菜单按钮。
提示数据源一起打开。

jscsj

ynzsvt 发表于 2024-8-4 17:20
自定义工具栏加了菜单按钮。
提示数据源一起打开。

这个代码多了一个菜单按钮，我点了一下，生成了一个表 但没有数据，数据都为0

我把我的四个数据文件放在附件中，便于你测试。

jscsj

quqiyuan 发表于 2024-8-4 16:12
参与一下，仅供参考。。。。

谢谢啦！用你的代码完成了！

ynzsvt

四个结果表

jscsj

ynzsvt 发表于 2024-8-4 17:20
自定义工具栏加了菜单按钮。
提示数据源一起打开。

谢谢啦。帮我全部完成了。下次一定说清楚。

ykcbf1100

參與一下。。。

ykcbf1100

參與一下。。

1. Sub ykcbf()   '//2024.8.4
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("Text 1")
   
5.     With Application.FileDialog(msoFileDialogFilePicker)
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         .Title = "请选择对应Excel文件"
   
8.         .AllowMultiSelect = False
   
9.         .Filters.Clear
   
10.         .Filters.Add "Excel文件", "*.xls*"
    
11.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
12.     End With
    
13.     ReDim brr(1 To 100000, 1 To 100)
    
14.     Set wb = Workbooks.Open(f, 0)
    
15.     For Each sht In wb.Sheets
    
16.         m = m + 1
    
17.         sum1 = 0: sum2 = 0: sum4 = 0: sum5 = 0: n = 0
    
18.         With sht
    
19.             r = .Cells(Rows.Count, 1).End(3).Row
    
20.             arr = .[a1].Resize(r, 5)
    
21.             fn = Replace(.Name, "__", "_")
    
22.             fn = Split(fn, "_")
    
23.         End With
    
24.         brr(m, 1) = fn(2)
    
25.         brr(m, 2) = fn(0)
    
26.         For i = 2 To UBound(arr)
    
27.             n = n + 1
    
28.             If InStr(arr(i, 5), "Trados") Then sum1 = sum1 + 1
    
29.             If InStr(arr(i, 5), "其他") Then sum2 = sum2 + 1
    
30.             If arr(i, 4) <> Empty Then sum4 = sum4 + 1
    
31.             If InStr(arr(i, 5), "Trados") Then sum5 = sum5 + arr(i, 3)
    
32.         Next
    
33.         brr(m, 3) = sum1
    
34.         brr(m, 4) = sum2
    
35.         brr(m, 5) = n - sum1 - sum2
    
36.         brr(m, 6) = sum4
    
37.         brr(m, 7) = sum5
    
38.     Next
    
39.     wb.Close 0
    
40.     With sh
    
41.         .UsedRange.Offset(1).ClearContents
    
42.         .[a2].Resize(m, 7) = brr
    
43.     End With
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub
    

复制代码

jscsj

ykcbf1100 发表于 2024-8-4 21:13
參與一下。。。

这个好，可以选择数据文件。

jscsj

ykcbf1100 发表于 2024-8-4 21:14
參與一下。。

求助，邀请你再参与一下。
按列分类统计计数
https://club.excelhome.net/thread-1698786-1-1.html
(出处: ExcelHome技术论坛)

ykcbf1100

jscsj 发表于 2024-8-5 13:05
求助，邀请你再参与一下。
按列分类统计计数
https://club.excelhome.net/thread-1698786-1-1.html

你这个我写不了，需求搞不明白。