多工作薄数据引用

Laughingsun889

老师们晚上好！计算比较繁琐，希望能用VBA提高效率，请各位老师帮忙。要求是，在材料成本表中编写代码，把单价表中的单价以材料代码为关键字引入清单文件夹中各个产品清单对应的材料单价中，并计算出对应的金额。注意：清单文件夹中各产品清单个数有时多有时少，单价表中的材料个数有时多有时少，不定！谢谢！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.6
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     p = ThisWorkbook.Path & ""
   
8.     fs = p & "单价表.xlsx"
   
9.     Set wb = Workbooks.Open(fs, 0)
   
10.     With wb.Sheets("Sheet1")
    
11.         arr = .UsedRange
    
12.         wb.Close False
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         d(arr(i, 2)) = arr(i, 6)
    
16.     Next
    
17.     p1 = p & "清单"
    
18.     For Each f In fso.GetFolder(p1).Files
    
19.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
20.             fn = fso.GetBaseName(f)
    
21.             Set wb = Workbooks.Open(f, 0)
    
22.             With wb.Sheets("Sheet1")
    
23.                 r = .Cells(Rows.Count, 1).End(3).Row
    
24.                 arr = .[a4].Resize(r - 3, 10)
    
25.                 For i = 2 To UBound(arr)
    
26.                     s = arr(i, 2)
    
27.                     If d.exists(s) Then
    
28.                         arr(i, 9) = d(s)
    
29.                         arr(i, 10) = arr(i, 8) * d(s)
    
30.                     End If
    
31.                 Next
    
32.                 .[a4].Resize(r - 3, 10) = arr
    
33.             End With
    
34.             wb.Close 1
    
35.         End If
    
36.     Next f
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
40. End Sub
    
41. 
    

复制代码

limonet

其实你在“材料成本表”做几个示范，会不会更好。

Laughingsun889

ykcbf1100 发表于 2024-5-6 20:26
参与一下。。。

谢谢老师，辛苦了，代码运行良好！只是把我H列原公式冲掉了，能否不冲掉清单各分表的公式，或者用代码重新计算H列数据：原公式=J2*标准用量*（1+损耗率）。

ykcbf1100

Laughingsun889 发表于 2024-5-7 08:12
谢谢老师，辛苦了，代码运行良好！只是把我H列原公式冲掉了，能否不冲掉清单各分表的公式，或者用代码重 ...

保留公式。。。

ykcbf1100

公式保留。。。

1. Sub ykcbf()  '//2024.5.7
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     p = ThisWorkbook.Path & ""
   
8.     fs = p & "单价表.xlsx"
   
9.     Set wb = Workbooks.Open(fs, 0)
   
10.     With wb.Sheets("Sheet1")
    
11.         arr = .UsedRange
    
12.         wb.Close False
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         d(arr(i, 2)) = arr(i, 6)
    
16.     Next
    
17.     p1 = p & "清单"
    
18.     For Each f In fso.GetFolder(p1).Files
    
19.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
20.             fn = fso.GetBaseName(f)
    
21.             m = 0
    
22.             Set wb = Workbooks.Open(f, 0)
    
23.             With wb.Sheets("Sheet1")
    
24.                 r = .Cells(Rows.Count, 1).End(3).Row
    
25.                 arr = .[a4].Resize(r - 3, 10)
    
26.                 ReDim brr(1 To UBound(arr), 1 To 2)
    
27.                 For i = 2 To UBound(arr)
    
28.                     s = arr(i, 2)
    
29.                     m = m + 1
    
30.                     If d.exists(s) Then
    
31.                         brr(m, 1) = d(s)
    
32.                         brr(m, 2) = arr(i, 8) * d(s)
    
33.                     End If
    
34.                 Next
    
35.                 .[i5].Resize(m, 2) = brr
    
36.             End With
    
37.             wb.Close 1
    
38.         End If
    
39.     Next f
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
43. End Sub
    

复制代码

david_jiao

ykcbf1100 发表于 2024-5-7 12:18
公式保留。。。

草爷老师是有求必应，值得尊敬，让人敬佩，最主要是真能解决问题，高手高手高高手！

Laughingsun889

ykcbf1100 发表于 2024-5-7 12:18
公式保留。。。

谢谢老师耐心的回复！