材料成本加工费按年月分布

chengshanming

1. Private Sub 材料加工成本_Click()
   
2.     Dim d, d1, i&, arr, brr, crr, j, s, total, k&, ar
   
3.     tt = Timer
   
4.     'Application.ScreenUpdating = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7. arr = Sheet2.Range(Sheet2.Cells(2, 1), Sheet2.Cells(Sheet2.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1, Sheet2.Cells.Find("*", , , , xlByColumns, xlPrevious).Column)) '单元格内容不为空的最大行列,不含各种格式.
   
8.    For i = 1 To UBound(arr, 1)
   
9.    d1(arr(i, 1) & arr(i, 2)) = Array(arr(i, 1), arr(i, 4), arr(i, 5), arr(i, 6))
   
10.    Next
    
11.    
    
12.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
13.     For i = 1 To UBound(arr) - 1
    
14.         s = arr(i, 2)
    
15.             If d(s) = "" Then
    
16.               M = M + 1
    
17.                 d(s) = M
    
18.                 brr(M, 1) = arr(i, 2)
    
19.                 brr(M, 2) = arr(i, 3)
    
20.         End If
    
21.     Next
    
22.    
    
23.     With Sheet1
    
24.         On Error Resume Next
    
25.       
    
26.         '.[a3].Resize(M, UBound(brr, 2)).Value = brr
    
27.         
    
28.     ar = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(Sheet1.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1, Sheet1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column)) '单元格内容不为空的最大行列,不含各种格式.
    
29.    ReDim crr(1 To UBound(brr), 1 To UBound(ar, 2))
    
30.    For i = 1 To UBound(brr, 1)
    
31.    crr(i, 1) = brr(i, 1)
    
32.    crr(i, 2) = brr(i, 2)
    
33.    
    
34.    For k = 1 To 3
    
35.    For j = 3 + 13 * (k - 1) To 15 + 13 * (k - 1)
    
36.    If d1(brr(i, 1))(0) = ar(2, j) Then
    
37.    crr(i, j) = d1(ar(2, j) & brr(i, 1))(k)
    
38.    End If
    
39.    Next j
    
40.    
    
41.   
    
42.     Next k
    
43.    Next i
    
44.     .UsedRange.Offset(2).ClearContents
    
45.      .[a3].Resize(UBound(brr), UBound(ar, 2)) = crr
    
46.     End With
    
47.     With Sheet1.Range("a2:AO" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    
48.     .AutoFilter
    
49.         .Font.Size = 9
    
50.         .NumberFormatLocal = "0.00"
    
51.         .Font.Name = "新細明體"
    
52.         .HorizontalAlignment = xlLeft
    
53.         .VerticalAlignment = xlBottom
    
54.     End With
    
55.     'Application.ScreenUpdating = True
    
56.        MsgBox "成本按年月更新完毕!" & Chr(10) & "共用 " & Format(Int((Timer - tt) / 3600), "00") & "时" & Format(Int((Timer - tt) / 60) - Int((Timer - tt) / 3600) * 60, "00") & "分" & Format((Timer - tt) - Int((Timer - tt) / 60) * 60, "00") & "秒！", vbInformation, "提示"
    
57. End Sub

复制代码