求助VBA制作表格~急用

通用软件么

将左侧表格按照受理网点所对应的业务名称和处理成功业务量做成红色模板表的格式

谢大神！！

通用软件么

下面是excel文件

通用软件么

excel文件在下面一条评论

狗尾巴草儿

通用软件么 发表于 2018-1-15 22:00
下面是excel文件

在sheet1后面新建一个表，选中sheet2右键查看代码，代码如下，注意：运行较慢
Sub ss()
Set a = Worksheets(1)
x = a.UsedRange.Rows.Count
Dim rng As Range, order As XlOrder, Header As XlYesNoGuess
Set rng = a.Range(a.Cells(1, 1), a.Cells(x, 3))
rng.Sort Key1:=a.Range(a.Cells(1, 1), a.Cells(1, 1)), Order1:=xlAscending, Header:=xlYes
m = 2
For i = 2 To x
If a.Cells(i, 1) <> a.Cells(i + 1, 1) And a.Cells(i, 1) <> "" Then
Cells(m, 1) = a.Cells(i, 1)
m = m + 1
End If
Next
Dim rg As Range
Set rg = a.Range(a.Cells(1, 1), a.Cells(x, 3))
rg.Sort Key1:=a.Range(a.Cells(1, 2), a.Cells(1, 2)), Order1:=xlAscending, Header:=xlYes
n = 2
For j = 2 To x
If a.Cells(j, 2) <> a.Cells(j + 1, 2) And a.Cells(j, 2) <> "" Then
Cells(1, n) = a.Cells(j, 2)
Cells(1, n + 1) = a.Cells(1, 3)
n = n + 2
End If
Next
xx = UsedRange.Rows.Count
y = UsedRange.Columns.Count
For e = 2 To xx
For f = 2 To y Step 2
For g = 2 To x
If Cells(e, 1) = a.Cells(g, 1) And Cells(1, f) = a.Cells(g, 2) Then
Cells(e, f) = a.Cells(g, 2)
Cells(e, f + 1) = a.Cells(g, 3)
End If
Next
Next
Next
End Sub

狗尾巴草儿

在sheet1后面新建sheet2，选中sheet2右键查看代码，代码如下，注意运行较慢

1. Sub ss()
   
2. Set a = Worksheets(1)
   
3. x = a.UsedRange.Rows.Count
   
4. Dim rng As Range, order As XlOrder, Header As XlYesNoGuess
   
5. Set rng = a.Range(a.Cells(1, 1), a.Cells(x, 3))
   
6. rng.Sort Key1:=a.Range(a.Cells(1, 1), a.Cells(1, 1)), Order1:=xlAscending, Header:=xlYes
   
7. m = 2
   
8. For i = 2 To x
   
9. If a.Cells(i, 1) <> a.Cells(i + 1, 1) And a.Cells(i, 1) <> "" Then
   
10. Cells(m, 1) = a.Cells(i, 1)
    
11. m = m + 1
    
12. End If
    
13. Next
    
14. Dim rg As Range
    
15. Set rg = a.Range(a.Cells(1, 1), a.Cells(x, 3))
    
16. rg.Sort Key1:=a.Range(a.Cells(1, 2), a.Cells(1, 2)), Order1:=xlAscending, Header:=xlYes
    
17. n = 2
    
18. For j = 2 To x
    
19. If a.Cells(j, 2) <> a.Cells(j + 1, 2) And a.Cells(j, 2) <> "" Then
    
20. Cells(1, n) = a.Cells(j, 2)
    
21. Cells(1, n + 1) = a.Cells(1, 3)
    
22. n = n + 2
    
23. End If
    
24. Next
    
25. xx = UsedRange.Rows.Count
    
26. y = UsedRange.Columns.Count
    
27. For e = 2 To xx
    
28. For f = 2 To y Step 2
    
29. For g = 2 To x
    
30. If Cells(e, 1) = a.Cells(g, 1) And Cells(1, f) = a.Cells(g, 2) Then
    
31. Cells(e, f) = a.Cells(g, 2)
    
32. Cells(e, f + 1) = a.Cells(g, 3)
    
33. End If
    
34. Next
    
35. Next
    
36. Next
    
37. End Sub
    
38. 
    
39. [img]C:\Users\ASUS\Desktop\效果图.png[/img]

复制代码

狗尾巴草儿

通用软件么 发表于 2018-1-15 22:00
下面是excel文件

楼主，加速版来了，新建sheet2运行此代码，很快

1. Sub 数组运行()        '4秒
   
2. Set a = Worksheets(1)
   
3. x = a.UsedRange.Rows.Count
   
4. Dim rng As Range, order As XlOrder, Header As XlYesNoGuess
   
5. Set rng = a.Range(a.Cells(1, 1), a.Cells(x, 3))
   
6. rng.Sort Key1:=a.Range(a.Cells(1, 1), a.Cells(1, 1)), Order1:=xlAscending, Header:=xlYes
   
7. m = 2
   
8. Dim t()
   
9. For i = 2 To x
   
10. ReDim Preserve t(i)
    
11. If a.Cells(i, 1) <> a.Cells(i + 1, 1) And a.Cells(i, 1) <> "" Then
    
12. t(i) = a.Cells(i, 1)
    
13. Cells(m, 1) = t(i)
    
14. m = m + 1
    
15. End If
    
16. Next
    
17. Dim rg As Range
    
18. Set rg = a.Range(a.Cells(1, 1), a.Cells(x, 3))
    
19. rg.Sort Key1:=a.Range(a.Cells(1, 2), a.Cells(1, 2)), Order1:=xlAscending, Header:=xlYes
    
20. n = 2
    
21. For j = 2 To x
    
22. If a.Cells(j, 2) <> a.Cells(j + 1, 2) And a.Cells(j, 2) <> "" Then
    
23. Cells(1, n) = a.Cells(j, 2)
    
24. Cells(1, n + 1) = a.Cells(1, 3)
    
25. n = n + 2
    
26. End If
    
27. Next
    
28. xx = UsedRange.Rows.Count
    
29. y = UsedRange.Columns.Count
    
30. k = Range(Cells(2, 1), Cells(xx, 1))
    
31. kk = Range(Cells(1, 2), Cells(1, y))
    
32. kkk = a.Range(a.Cells(2, 1), a.Cells(x, 3))
    
33. For e = 1 To xx - 1
    
34. For f = 1 To y - 1 Step 2
    
35. For g = 1 To x - 1
    
36. If k(e, 1) = kkk(g, 1) And kk(1, f) = kkk(g, 2) Then
    
37. Cells(e + 1, f + 1) = kkk(g, 2)
    
38. Cells(e + 1, f + 2) = kkk(g, 3)
    
39. End If
    
40. Next
    
41. Next
    
42. Next
    
43. End Sub

复制代码

狗尾巴草儿

通用软件么 发表于 2018-1-15 22:00
下面是excel文件

那啥，我好像看到了你的回复，但是我不知道在哪回答你，通用的话可能还不行，需要调整一些东西，但是如果是你这个格式的excel，只有一个工作表，同时只有三列数据，那是可以用的。如果用在其他文件上，可能需要调整一下

狗尾巴草儿

对不起，前面仨有问题，漏了数据，现在是改版，应该不能跟格式不一样的通用，这个不用新建工作表，直接选中sheet1,右键查看代码，粘贴运行就行了

1. Sub 数组运行()                                    '15秒
   
2. Worksheets.Add after:=Worksheets("sheet1")
   
3. ActiveSheet.Name = "汇总"
   
4. Set b = Worksheets("汇总")
   
5. Set a = Worksheets(1)
   
6. x = a.UsedRange.Rows.Count
   
7. Dim rng As Range, order As XlOrder, Header As XlYesNoGuess
   
8. Set rng = a.Range(a.Cells(1, 1), a.Cells(x, 3))
   
9. rng.Sort Key1:=a.Range(a.Cells(1, 1), a.Cells(1, 1)), Order1:=xlAscending, Header:=xlYes
   
10. m = 2
    
11. Dim t()
    
12. For i = 2 To x
    
13. ReDim Preserve t(i)
    
14. If a.Cells(i, 1) <> a.Cells(i + 1, 1) And a.Cells(i, 1) <> "" Then
    
15. t(i) = a.Cells(i, 1)
    
16. b.Cells(m, 1) = t(i)
    
17. m = m + 1
    
18. End If
    
19. Next
    
20. Dim rg As Range
    
21. Set rg = a.Range(a.Cells(1, 1), a.Cells(x, 3))
    
22. rg.Sort Key1:=a.Range(a.Cells(1, 2), a.Cells(1, 2)), Order1:=xlAscending, Header:=xlYes
    
23. n = 2
    
24. For j = 2 To x
    
25. If a.Cells(j, 2) <> a.Cells(j + 1, 2) And a.Cells(j, 2) <> "" Then
    
26. b.Cells(1, n) = a.Cells(j, 2)
    
27. b.Cells(1, n + 1) = a.Cells(1, 3)
    
28. n = n + 2
    
29. End If
    
30. Next
    
31. xx = UsedRange.Rows.Count
    
32. y = UsedRange.Columns.Count
    
33. k = b.Range(b.Cells(2, 1), b.Cells(xx, 1))
    
34. kk = b.Range(b.Cells(1, 2), b.Cells(1, y))
    
35. kkk = a.Range(a.Cells(2, 1), a.Cells(x, 3))
    
36. For e = 1 To xx - 1
    
37. For f = 1 To y - 1 Step 2
    
38. For g = 1 To x - 1
    
39. If k(e, 1) = kkk(g, 1) And kk(1, f) = kkk(g, 2) Then
    
40. b.Cells(e + 1, f + 1) = kkk(g, 2)
    
41. b.Cells(e + 1, f + 2) = kkk(g, 3) + b.Cells(e + 1, f + 2)
    
42. End If
    
43. Next
    
44. Next
    
45. Next
    
46. b.Cells(1, 1) = "受理网点"
    
47. End Sub
    
48. 
    

复制代码