请各位老师帮忙看表格里面的公式能否用VBA处理出来结果？多谢！！

2728911088

请各位老师帮忙看表格里面的公式能否用VBA处理出来结果？多谢！！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d1 As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   With Worksheets("齐套明细")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:g" & r)
   
10.     For i = 1 To UBound(arr)
    
11.       d1(arr(i, 2)) = d1(arr(i, 2)) + arr(i, 6)
    
12.     Next
    
13.   End With
    
14.   With Worksheets("分类")
    
15.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
16.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
17.     arr = .Range("a1").Resize(r, c)
    
18.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
19.     For j = 1 To UBound(arr, 2) Step 3
    
20.       d.RemoveAll
    
21.       For i = 2 To UBound(arr)
    
22.         If Len(arr(i, j)) <> 0 Then
    
23.           If d1.exists(arr(i, j)) Then
    
24.             d(arr(i, j + 1)) = d(arr(i, j + 1)) + d1(arr(i, j))
    
25.           End If
    
26.         End If
    
27.       Next
    
28.       brr(1, j) = Left(arr(1, j), 1) & arr(1, j + 1) & Mid(arr(1, j), 2)
    
29.       brr(1, j + 1) = "数量"
    
30.       m = 1
    
31.       For Each aa In d.keys
    
32.         m = m + 1
    
33.         brr(m, j) = aa
    
34.         brr(m, j + 1) = d(aa)
    
35.       Next
    
36.     Next
    
37.   End With
    
38.   With Worksheets("汇总")
    
39.     .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
40.   End With
    
41. End Sub
    

复制代码

chxw68

后面的一些没看懂，没有写完。

2728911088

chxw68 发表于 2018-9-11 21:33
后面的一些没看懂，没有写完。

感谢老师，非常感谢，辛苦了。

产品	计划组		产品	计划组
核心网	FAF		服务器	MM/SI
核心网	SAF		服务器	LKDSJ
核心网	QE		服务器	DSAFJL
核心网	FAQ		服务器	FASD
核心网	ERW		服务器	ASQ
核心网	FA		服务器	QWR
核心网	RET		服务器	WEQR
核心网	WQER
核心网	AFWQ

主要是这个要拆分出来，核心网和服务器要分开，分开的原则是根据上面的计划组来区别。

核心网及服务器代码机型	数量
FD,SA	4945
DSFJLKA	1946
QWE	3900
RIQU	4462
HGAD	3963

拆分后的结果是如下：请老师再帮忙看看，感谢感谢！！

核心网代码机型	数量		服务器代码机型	数量
DSFJLKA	635		DSFJLKA	1311
FD,SA	1688		FD,SA	3257
HGAD	2070		HGAD	1893
QWE	2723		QWE	1177
RIQU	3803		RIQU	659

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d1 As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Set d2 = CreateObject("scripting.dictionary")
   
8.   Set d3 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("齐套明细")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:g" & r)
    
12.     For i = 1 To UBound(arr)
    
13.       If Not d1(arr(i, 2)) Then
    
14.         ReDim brr(1 To 2)
    
15.         brr(1) = arr(i, 4)
    
16.       Else
    
17.         brr = d1(arr(i, 2))
    
18.       End If
    
19.       brr(2) = brr(2) + arr(i, 6)
    
20.       d1(arr(i, 2)) = brr
    
21.     Next
    
22.   End With
    
23.   With Worksheets("核心网和服务器计划组分类")
    
24.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
25.     arr = .Range("a2:e" & r)
    
26.     For j = 1 To 4 Step 3
    
27.       For i = 1 To UBound(arr)
    
28.         If Len(arr(i, j)) <> 0 Then
    
29.           d2(arr(i, j + 1)) = arr(i, j)
    
30.         End If
    
31.       Next
    
32.     Next
    
33.   End With
    
34.   With Worksheets("分类")
    
35.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
36.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
37.     arr = .Range("a1").Resize(r, c)
    
38.     For j = 1 To UBound(arr, 2) Step 3
    
39.       For i = 2 To UBound(arr)
    
40.         If Len(arr(i, j)) <> 0 Then
    
41.           If d1.exists(arr(i, j)) Then
    
42.             crr = d1(arr(i, j))
    
43.             xm = ""
    
44.             If arr(1, j) <> "核心网及服务器代码" Then
    
45.               xm = arr(1, j)
    
46.             Else
    
47.               If d2.exists(crr(1)) Then
    
48.                 xm = d2(crr(1))
    
49.               End If
    
50.             End If
    
51.             If xm <> "" Then
    
52.               If Not d.exists(xm) Then
    
53.                 Set d(xm) = CreateObject("scripting.dictionary")
    
54.               End If
    
55.               d(xm)(arr(i, j + 1)) = d(xm)(arr(i, j + 1)) + crr(2)
    
56.             End If
    
57.           End If
    
58.         End If
    
59.       Next
    
60.     Next
    
61.   End With
    
62.   With Worksheets("汇总")
    
63.     .Cells.ClearContents
    
64.     n = 1
    
65.     For Each aa In d.keys
    
66.       .Cells(1, n) = aa & "机型"
    
67.       .Cells(1, n + 1) = "数量"
    
68.       .Cells(2, n).Resize(d(aa).Count, 2) = Application.Transpose(Array(d(aa).keys, d(aa).items))
    
69.       n = n + 3
    
70.     Next
    
71.   End With
    
72. End Sub
    

复制代码

chxw68

数据之间的关系挺绕人的，这次应该对了，有空了把代码再捋一捋。

2728911088

感谢老师，晚上回去电脑上送花，辛苦了，另外请问下老师，如果齐套分析里面的代码有重复的，是不是运行就会出错，

2728911088

chxw68 发表于 2018-9-12 08:20
数据之间的关系挺绕人的，这次应该对了，有空了把代码再捋一捋。

非常非常感谢，辛苦了，一开始模拟数据准备的不全，因为出现重复代码的时候就计算不了，重复的代码数量是要相加的。烦请再看看，感谢感谢！！！

chxw68

2728911088 发表于 2018-9-12 18:40
非常非常感谢，辛苦了，一开始模拟数据准备的不全，因为出现重复代码的时候就计算不了，重复的代码数量是 ...

楼主把我的代码都已经删除了，我还忙活着写什么呢？

2728911088

chxw68 发表于 2018-9-12 18:52
楼主把我的代码都已经删除了，我还忙活着写什么呢？

失误，把附件上传错了，因为附件名称一样，不好意思，抱歉。