如何将数据自动填入清单表？

scnc001

各位老师，

如何将数据自动填入清单表？

将xls文件的数量填入到清单表的最后一个空列，清单表中没有的项目就新增进来。

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("清单总表")
   
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
    

复制代码

liulang0808

Sub 按钮1_Click()
With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应Excel文件"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xls*"
        If .Show Then f = .SelectedItems(1) Else Exit Sub '
    End With
    Set d = CreateObject("scripting.dictionary")
    c = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r + 1000, c)
    For j = 2 To UBound(arr)
        d(arr(j, 1) & "##" & arr(j, 2)) = j
    Next j
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks.Open(f)
        brr = .Sheets(1).UsedRange
        .Close False
    End With
    For j = 2 To UBound(brr)
        str1 = brr(j, 1) & "##" & brr(j, 2)
        If d.exists(str1) Then
            arr(d(str1), c) = brr(j, 3)
            arr(d(str1), 4) = arr(d(str1), 4) + brr(j, 3)
        Else
            r = r + 1
            arr(r, 1) = brr(j, 1)
            arr(r, 2) = brr(j, 2)
            arr(r, c) = brr(j, 3)
            arr(r, 4) = brr(j, 3)
            d(str1) = r
        End If
    Next j
    crr = Split(f, "\")
    arr(1, c) = Split(crr(UBound(crr)), ".xls")(0)
    [a1].Resize(r, c) = arr
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。。

scnc001

ykcbf1100 发表于 2024-8-19 10:50
数据更新。。。。

非常感谢，很好用

scnc001

liulang0808 发表于 2024-8-19 11:01
Sub 按钮1_Click()
With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName  ...

很好用。非常感谢

scnc001

liulang0808 发表于 2024-8-19 11:02
供参考。。。。。。

请教一下：想在D列填充"=sum(Di:ZZi)"（i为行号）的公式，临时删除列时实时看到结果变化，不用vba求和，代码怎么写？

或者原代码不要覆盖我在原表格D列中写的公式（注释了求和的原代码后，D列为空时一直为空，只要写上公式就会被填充原有列的和）

liulang0808

Sub 按钮1_Click()
With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应Excel文件"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xls*"
        If .Show Then f = .SelectedItems(1) Else Exit Sub '
    End With
    Set d = CreateObject("scripting.dictionary")
    c = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r + 1000, c)
    For j = 2 To UBound(arr)
        d(arr(j, 1) & "##" & arr(j, 2)) = j
    Next j
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks.Open(f)
        brr = .Sheets(1).UsedRange
        .Close False
    End With
    For j = 2 To UBound(brr)
        str1 = brr(j, 1) & "##" & brr(j, 2)
        If d.exists(str1) Then
            arr(d(str1), c) = brr(j, 3)
            arr(d(str1), 4) = arr(d(str1), 4) + brr(j, 3)
        Else
            r = r + 1
            arr(r, 1) = brr(j, 1)
            arr(r, 2) = brr(j, 2)
            arr(r, 3) = brr(j, 4)
            arr(r, c) = brr(j, 3)
            arr(r, 4) = brr(j, 3)
            d(str1) = r
        End If
    Next j
    crr = Split(f, "\")
    arr(1, c) = Split(crr(UBound(crr)), ".xls")(0)
    [a1].Resize(r, c) = arr
    [d2] = "=sum(e2:z2)"
    [d2].Copy Range("d3:d" & r)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

变通了一下，供参考。。。。。