每月需要将销售员工信息业绩表汇总，既有新增的员工，也需要将老员工的业绩录入汇总表

辉太狼－2014

ykcbf1100 发表于 2024-8-17 20:01
能不能解决另说，关键是上传的附件要有数据。
你求助这么不认真，你还希望别人能认真帮你解决问题？

不好意思，数据重新上传了，真不是不认真，是我之前对VBA不了解的！

辉太狼－2014

不好意思！数据来了！

辉太狼－2014

Onemeter 发表于 2024-8-17 23:01
楼主怕泄漏公司，员工信息，可以顺便取个名字。如：小王，小刘都可以。
没附件大神们也是爱莫能助

收到，谢谢!

辉太狼－2014

songshihai 发表于 2024-8-17 20:13
咋数据都没有,咋写???????????????????????

不好意思，数据来了！

ykcbf1100

辉太狼－2014 发表于 2024-8-18 14:13
收到，谢谢!

季度有３个排名，不知道用哪个就没做。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.18
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     b = [{"b2","d2","f2","h2","j2","b3","e3","j3","b4","f4"}]
   
8.     ReDim brr(1 To 10000, 1 To 10)
   
9.     For Each fd In fso.GetFolder(p).SubFolders
   
10.         For Each f In fd.Files
    
11.             fn = fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets("Sheet1")
    
14.                 arr = .UsedRange
    
15.                 s = .Range(b(1)).Value
    
16.                 If Not d.exists(s) Then
    
17.                     m = m + 1
    
18.                     d(s) = m
    
19.                     For j = 1 To UBound(b)
    
20.                         brr(m, j) = .Range(b(j)).Value
    
21.                     Next
    
22.                 End If
    
23.                 For j = 3 To UBound(arr, 2) Step 2
    
24.                     For i = 10 To 21
    
25.                         s = .Range(b(1)).Value & "|" & arr(9, j) & "|" & arr(i, 2)
    
26.                         d(s) = d(s) + arr(i, j)
    
27.                     Next
    
28.                 Next
    
29.             End With
    
30.             wb.Close 0
    
31.         Next
    
32.     Next
    
33.     With sh
    
34.         .UsedRange.Offset(4).ClearContents
    
35.         .[a5].Resize(m, 10) = brr
    
36.         arr = .UsedRange
    
37.         For j = 11 To 58
    
38.             If arr(3, j) <> Empty Then st = arr(3, j)
    
39.             For i = 5 To UBound(arr)
    
40.                 s = arr(i, 1) & "|" & st & "|" & arr(4, j)
    
41.                 If d.exists(s) Then
    
42.                     arr(i, j) = d(s)
    
43.                 End If
    
44.             Next
    
45.         Next
    
46.          .UsedRange = arr
    
47.          ActiveWindow.DisplayZeros = False
    
48.     End With
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = False
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

辉太狼－2014

ykcbf1100 发表于 2024-8-18 20:50
参与一下。。。

谢谢，我来学习下！

ykcbf1100

按题意，汇总数据更新个人最新信息。

ykcbf1100

更新一下，个人信息更新为最新信息。

1. Sub ykcbf()   '//2024.8.19
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     b = [{"b2","d2","f2","h2","j2","b3","e3","j3","b4","f4"}]
   
8.     ReDim brr(1 To 10000, 1 To 10)
   
9.     For Each fd In fso.GetFolder(p).SubFolders
   
10.         For Each f In fd.Files
    
11.             fn = fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets("Sheet1")
    
14.                 arr = .UsedRange
    
15.                 s = .Range(b(1)).Value
    
16.                 If Not d.exists(s) Then
    
17.                     m = m + 1
    
18.                     d(s) = m
    
19.                     For j = 1 To UBound(b)
    
20.                         brr(m, j) = .Range(b(j)).Value
    
21.                     Next
    
22.                 Else
    
23.                     r = d(s)
    
24.                     For j = 2 To UBound(b)
    
25.                         brr(r, j) = .Range(b(j)).Value
    
26.                     Next
    
27.                 End If
    
28.                 For j = 3 To UBound(arr, 2) Step 2
    
29.                     For i = 10 To 21
    
30.                         s = .Range(b(1)).Value & "|" & arr(9, j) & "|" & arr(i, 2)
    
31.                         d(s) = d(s) + arr(i, j)
    
32.                     Next
    
33.                 Next
    
34.             End With
    
35.             wb.Close 0
    
36.         Next
    
37.     Next
    
38.     With sh
    
39.         .UsedRange.Offset(4).ClearContents
    
40.         .[a5].Resize(m, 10) = brr
    
41.         arr = .UsedRange
    
42.         For j = 11 To 58
    
43.             If arr(3, j) <> Empty Then st = arr(3, j)
    
44.             For i = 5 To UBound(arr)
    
45.                 s = arr(i, 1) & "|" & st & "|" & arr(4, j)
    
46.                 If d.exists(s) Then
    
47.                     arr(i, j) = d(s)
    
48.                 End If
    
49.             Next
    
50.         Next
    
51.         .UsedRange = arr
    
52.         ActiveWindow.DisplayZeros = False
    
53.     End With
    
54.     Set d = Nothing
    
55.     Application.ScreenUpdating = False
    
56.     MsgBox "OK！"
    
57. End Sub
    
58. 
    

复制代码

辉太狼－2014

ykcbf1100 发表于 2024-8-19 07:40
按题意，汇总数据更新个人最新信息。

解压出来的文件，报错不，按楼下的修改吗？