多个工作表按照特定表头对数据进行汇总

guzhenguo

将工作簿中数据按照汇总工作表中格式，以日期为依据对表头对应的数据进行汇总，并输出到汇总工作表中

3190496160

本来是个数组+字典就可以搞定的问题，但是，不明白，为什么有的工作表内有会多个表头呢？

guzhenguo

3190496160 发表于 2024-8-14 16:33
本来是个数组+字典就可以搞定的问题，但是，不明白，为什么有的工作表内有会多个表头呢？

两个不同生产线导出来的数据

ykcbf1100

分表结构混乱，为啥搞这么乱啊，不是同一个人做的表？

guzhenguo

ykcbf1100 发表于 2024-8-14 16:40
分表结构混乱，为啥搞这么乱啊，不是同一个人做的表？

生产系统导出的数据，表头基本都一致吧。

joy.008@163.com

遍历工作簿 把日期和台头一起做索引制成字典 然后回填

guzhenguo

joy.008@163.com 发表于 2024-8-14 16:47
遍历工作簿 把日期和台头一起做索引制成字典 然后回填

我试着用gpt等编的vba但是效果都不好

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.14
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("汇总")
   
6.     arr = sh.UsedRange
   
7.     For j = 2 To UBound(arr, 2)
   
8.         s = arr(1, j)
   
9.         d1(s) = j
   
10.     Next
    
11.     On Error Resume Next
    
12.     For Each sht In Sheets
    
13.         If Val(sht.Name) Then
    
14.             With sht
    
15.                 r = .Cells(Rows.Count, 1).End(3).Row
    
16.                 Set Rng = .UsedRange.Find("生产日期", LookIn:=xlValues)
    
17.                 bt = Rng.Row: col = Rng.Column
    
18.                 c = .Cells(bt, "XFD").End(1).Column
    
19.                 arr = .[a1].Resize(r, c)
    
20.             End With
    
21.             For i = bt + 1 To UBound(arr)
    
22.                 rq = FormatDateTime(CDate(arr(i, col)), 2)
    
23.                 If IsDate(rq) = True Then
    
24.                     For j = 1 To UBound(arr, 2)
    
25.                         s1 = arr(bt, j)
    
26.                         If d1.exists(s1) Then
    
27.                             s = rq & "|" & s1
    
28.                             d(s) = d(s) + arr(i, j)
    
29.                         End If
    
30.                     Next
    
31.                 End If
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Offset(1, 1).ClearContents
    
37.         arr = .UsedRange
    
38.         For i = 2 To UBound(arr)
    
39.             For j = 2 To UBound(arr, 2)
    
40.                 s = arr(i, 1) & "|" & arr(1, j)
    
41.                 If d.exists(s) Then
    
42.                     arr(i, j) = Round(d(s), 2)
    
43.                 End If
    
44.             Next
    
45.         Next
    
46.         .UsedRange = arr
    
47.     End With
    
48.     Set d = Nothing
    
49.     Set d1 = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

ykcbf1100

guzhenguo 发表于 2024-8-14 16:49
我试着用gpt等编的vba但是效果都不好

你这样的数据结构让gpt去写代码，你这是为难gpt了。