将进货及销售按照进销存的格式自动汇总

guo277272718

麻烦老师帮忙指点，谢谢大家了！

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr, x$, Myr&, Crr
   
3. Dim d, k, t, d1, k1, t1, d2
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Set d2 = CreateObject("Scripting.Dictionary")
   
7. Application.ScreenUpdating = False
   
8. Application.DisplayAlerts = False
   
9. Sheet5.Activate
   
10. [a3:i5000].ClearContents
    
11. Arr = Sheet1.[a1].CurrentRegion
    
12. For i = 3 To UBound(Arr)
    
13.     If Arr(i, 1) = "" Then Exit For
    
14.     x = Arr(i, 1) & "," & Arr(i, 2) & "," & Arr(i, 4)
    
15.     d(x) = d(x) & i & ","
    
16. Next
    
17. Brr = Sheet2.[a1].CurrentRegion
    
18. For i = 3 To UBound(Brr)
    
19.     If Brr(i, 1) = "" Then Exit For
    
20.     x = Brr(i, 1) & "," & Brr(i, 2) & "," & Brr(i, 4)
    
21.     d1(x) = d1(x) & i & ","
    
22. Next
    
23. k = d.keys: t = d.items: k1 = d1.keys: t1 = d1.items
    
24. [a3].Resize(d.Count) = Application.Transpose(k)
    
25. For i = 0 To UBound(k1)
    
26.     If Not d.exists(k1(i)) Then
    
27.         Myr = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
28.         Cells(Myr, 1) = k1(i)
    
29.     End If
    
30. Next
    
31. Crr = [a1].CurrentRegion
    
32. For i = 3 To UBound(Crr)
    
33.     d2(Crr(i, 1)) = i
    
34. Next
    
35. For i = 0 To UBound(k)
    
36.     n = d2(k(i))
    
37.     t(i) = Left(t(i), Len(t(i)) - 1)
    
38.     If InStr(t(i), ",") Then
    
39.         aa = Split(t(i), ",")
    
40.         For j = 0 To UBound(aa)
    
41.             Cells(n, 6) = Cells(n, 6) + Arr(aa(j), 6)
    
42.             Cells(n, 7) = Cells(n, 7) + Arr(aa(j), 8)
    
43.         Next
    
44.     Else
    
45.         Cells(n, 6) = Arr(t(i), 6): Cells(n, 7) = Arr(t(i), 8)
    
46.     End If
    
47. Next
    
48. For i = 0 To UBound(k1)
    
49.     n = d2(k1(i))
    
50.     t1(i) = Left(t1(i), Len(t1(i)) - 1)
    
51.     If InStr(t1(i), ",") Then
    
52.         aa = Split(t1(i), ",")
    
53.         For j = 0 To UBound(aa)
    
54.             Cells(n, 8) = Cells(n, 8) + Arr(aa(j), 6)
    
55.             Cells(n, 9) = Cells(n, 9) + Arr(aa(j), 8)
    
56.         Next
    
57.     Else
    
58.         Cells(n, 8) = Arr(t1(i), 6): Cells(n, 9) = Arr(t1(i), 8)
    
59.     End If
    
60. Next
    
61. [a3].Resize(UBound(Crr) - 2).TextToColumns DataType:=xlDelimited, Comma:=True
    
62. Application.DisplayAlerts = True
    
63. Application.ScreenUpdating = True
    
64. End Sub
    

复制代码

liuym

下载下来学习

guo277272718

蓝桥玄霜 发表于 2016-1-29 14:16

非常感谢老师，老师，还有一种情况如果是每次的进货价不一样它是怎么运行的呢？[em17]