数据汇集填表求助

scnc001

求助各位大佬，现有一个工作量表（匹配 定额编号）需要分项按列填写，原表已有项目的直接填入到对应定额编号所在行，原表没有的项目，就按定额编号顺序插入一行再填入（不好实现的话，在最后一行增加也行）。

万分感谢！

只是、那个人

定额编号相同但是项目名不同  他们是一个东西嘛？如TXL1-002两个表内的项目名就不同

鄂龙蒙

多表汇总.rar (37.58 KB, 下载次数: 6)

2024-8-17 15:07 上传

点击文件名下载附件

鄂龙蒙

完善一下
多表汇总.rar (45.98 KB, 下载次数: 17)

2024-8-17 15:32 上传

点击文件名下载附件

scnc001

只是、那个人 发表于 2024-8-17 14:44
定额编号相同但是项目名不同  他们是一个东西嘛？如TXL1-002两个表内的项目名就不同

以编号为准，后面的是从图纸里导出来的，意思一样，表述有偏差。匹配编号即可

scnc001

鄂龙蒙 发表于 2024-8-17 15:33
完善一下

谢谢！需要在“图纸3”后面的空列填入新文件的数据，原有的数据不动。各列数据的顺序也不用调，需要调的是定额编号，比如新文件有一条TXL3-099的记录，现表在TXL3-001之后是TXL3-101,在这之间插入。受累再完善一下？谢谢！

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.     With sh
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         c = .Cells(1, "XFD").End(1).Column
   
9.         arr = .[a1].Resize(r, c)
   
10.     End With
    
11.     ReDim brr(1 To 10000, 1 To 100)
    
12.     n = 4
    
13.     For i = 1 To UBound(arr)
    
14.         s = arr(i, 1)
    
15.         If Not d.exists(s) Then
    
16.             m = m + 1
    
17.             d(s) = m
    
18.             For j = 1 To UBound(arr, 2)
    
19.                 brr(m, j) = arr(i, j)
    
20.             Next
    
21.         End If
    
22.         r = d(arr(i, 1))
    
23.         For j = 5 To UBound(arr, 2)
    
24.             s = CStr(arr(1, j))
    
25.             If Not d.exists(s) Then
    
26.                 n = n + 1
    
27.                 d(s) = n
    
28.             End If
    
29.         Next
    
30.     Next
    
31.     With Application.FileDialog(msoFileDialogFilePicker)
    
32.         .InitialFileName = ThisWorkbook.Path & ""
    
33.         .Title = "请选择对应Excel文件"
    
34.         .AllowMultiSelect = False
    
35.         .Filters.Clear
    
36.         .Filters.Add "Excel文件", "*.xls*"
    
37.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
38.     End With
    
39.     fn = fso.GetBaseName(f)
    
40.     Set wb = Workbooks.Open(f, 0)
    
41.     With wb.Sheets("Sheet2")
    
42.         r = .Cells(Rows.Count, 1).End(3).Row
    
43.         arr = .[a1].Resize(r, 4)
    
44.     End With
    
45.     wb.Close 0
    
46.     On Error Resume Next
    
47.     If Not d.exists(fn) Then
    
48.         n = n + 1
    
49.         d(fn) = n
    
50.         brr(1, n) = fn
    
51.     End If
    
52.     c = d(fn)
    
53.     For i = 2 To UBound(arr)
    
54.         s = arr(i, 1)
    
55.         If Not d.exists(s) Then
    
56.             m = m + 1
    
57.             d(s) = m
    
58.             brr(m, 1) = arr(i, 1)
    
59.             brr(m, 2) = arr(i, 2)
    
60.             brr(m, 3) = arr(i, 4)
    
61.             brr(m, c) = arr(i, 3)
    
62.         End If
    
63.         r = d(arr(i, 1))
    
64.         brr(r, c) = arr(i, 3)
    
65.     Next
    
66.     With sh
    
67.         .UsedRange.Clear
    
68.         .[a1].Resize(1, n).Interior.Color = 49407
    
69.         With .[a1].Resize(m, n)
    
70.             .Value = brr
    
71.             .Borders.LineStyle = 1
    
72.             .HorizontalAlignment = xlCenter
    
73.             .VerticalAlignment = xlCenter
    
74.         End With
    
75.         For i = 2 To m
    
76.             .Cells(i, 4) = Application.Sum(.Cells(i, 5).Resize(, c - 4))
    
77.         Next
    
78.     End With
    
79.     Set d = Nothing
    
80.     Application.ScreenUpdating = False
    
81.     MsgBox "OK！"
    
82. End Sub
    
83. 
    

复制代码

usedrange

1. Sub gg()
   
2.     Dim fso, fs, f, i%, j%, m%, pa$, wb, dat, n%, ar, br, t, r%, p%, jp
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     pa = ThisWorkbook.Path
   
5.     Set fs = fso.getfolder(pa)
   
6.     m = Workbooks(ThisWorkbook.Name).Sheets(1).[a1].End(4).Row
   
7.     ReDim ar(1 To m, 1 To 1)
   
8.     Application.ScreenUpdating = False
   
9.     For Each f In fs.Files
   
10.         If f.Name Like "*.xlsx" And Not (f.Name Like "~$*") Then
    
11.             Set wb = Workbooks.Open(f)
    
12.             dat = [a1].CurrentRegion
    
13.             wb.Close
    
14.             Set wb = Nothing
    
15.             n = [a1].End(xlToRight).Column + 1
    
16.             Cells(1, n) = Split(f.Name, ".")(0)
    
17.             ReDim br(1 To UBound(dat), 1 To n)
    
18.             r = 1
    
19.             For i = 2 To UBound(dat)
    
20.                 t = 1
    
21.                 For j = 2 To m
    
22.                     If dat(i, 1) = Cells(j, 1) Then
    
23.                         ar(j - 1, 1) = dat(i, 3)
    
24.                         t = 0
    
25.                         Exit For
    
26.                     End If
    
27.                 Next j
    
28.                 If t Then
    
29.                     For p = 1 To 4
    
30.                         If p < 3 Then
    
31.                             br(r, p) = dat(i, p)
    
32.                         ElseIf p = 3 Then
    
33.                             br(r, p) = dat(i, p + 1)
    
34.                         ElseIf p = 4 Then
    
35.                             br(r, p) = "=sum(e" & j + r - 1 & ":rr" & j + r - 1 & ")"
    
36.                         End If
    
37.                     Next p
    
38.                     br(r, n) = dat(i, 3)
    
39.                     t = 1
    
40.                     r = r + 1
    
41.                 End If
    
42.             Next i
    
43.             Cells(2, n).Resize(UBound(ar), 1) = ar
    
44.             Cells(m + 1, 1).Resize(UBound(br), n) = br
    
45.         End If
    
46.     Next f
    
47.     Set jp = Sheet1.[a1].CurrentRegion
    
48.     jp.Sort key1:="定额编号", Header:=xlYes
    
49.     Set jp = Nothing
    
50.     Set fso = Nothing
    
51.     Set fs = Nothing
    
52.     Application.ScreenUpdating = True
    
53. End Sub
    

复制代码

scnc001

ykcbf1100 发表于 2024-8-19 10:54
参与一下。。。

感谢老师的指点