[已解决]提取数据并均分为多列

lidayu

请老师赐教如何实现夸表提取数据并均分为多列,详情附件中,谢谢! 提取数据并均分为多列0906.rar (29.93 KB, 下载次数: 30)

2015-9-6 12:54 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-6 15:39

1. Sub tt()
   
2.     [a:d].Clear
   
3.     arr = Sheets("数据源表").[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 6) <> "" Then
   
8.             x = arr(i, 1)
   
9.             n = n + 1
   
10.             d(x) = d(x) + 1
    
11.             d1(x) = d1(x) & "," & arr(i, 6)
    
12.         End If
    
13.     Next
    
14.     ReDim brr(1 To 1 + Int((n + d.Count) / 4), 1 To 4)  '分成四列
    
15.     i = 0: j = 1
    
16.     For Each x In d.keys
    
17.         d1(x) = x & "   计：" & d(x) & d1(x)
    
18.         xrr = Split(d1(x), ",")
    
19.         For k = 0 To UBound(xrr)
    
20.             i = i + 1
    
21.             If i > UBound(brr) Then i = 1: j = j + 1
    
22.             brr(i, j) = xrr(k)
    
23.             If k = 0 Then Cells(i + 1, j).Font.Bold = True
    
24.         Next
    
25.     Next
    
26.     [a:d].NumberFormatLocal = "@"      '设置文本格式
    
27.     [a2].Resize(UBound(brr), j) = brr
    
28.     [a:d].Columns.AutoFit
    
29.     [a1] = "单位警号汇总"
    
30.     [a1:d1].Merge
    
31.     [a1:d1].Font.Bold = True
    
32. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     [a:d].Clear
   
3.     arr = Sheets("数据源表").[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 6) <> "" Then
   
8.             x = arr(i, 1)
   
9.             n = n + 1
   
10.             d(x) = d(x) + 1
    
11.             d1(x) = d1(x) & "," & arr(i, 6)
    
12.         End If
    
13.     Next
    
14.     ReDim brr(1 To 1 + Int((n + d.Count) / 4), 1 To 4)  '分成四列
    
15.     i = 0: j = 1
    
16.     For Each x In d.keys
    
17.         d1(x) = x & "   计：" & d(x) & d1(x)
    
18.         xrr = Split(d1(x), ",")
    
19.         For k = 0 To UBound(xrr)
    
20.             i = i + 1
    
21.             If i > UBound(brr) Then i = 1: j = j + 1
    
22.             brr(i, j) = xrr(k)
    
23.             If k = 0 Then Cells(i + 1, j).Font.Bold = True
    
24.         Next
    
25.     Next
    
26.     [a:d].NumberFormatLocal = "@"      '设置文本格式
    
27.     [a2].Resize(UBound(brr), j) = brr
    
28.     [a:d].Columns.AutoFit
    
29.     [a1] = "单位警号汇总"
    
30.     [a1:d1].Merge
    
31.     [a1:d1].Font.Bold = True
    
32. End Sub
    

复制代码

grf1973

请看附件。

lidayu

grf1973 发表于 2015-9-6 15:39
请看附件。

您好，非常感谢您的帮助，能否再设置下A1的“单位警号汇总”自动居中“及单元黑色边框，谢谢！

grf1973

好办。

1122wen

grf1973 发表于 2015-9-6 15:39
请看附件。

代码看得不太懂，好累。要是能给个解释篇就好了

lidayu

grf1973 发表于 2015-9-7 10:25
好办。

grf1973您好，在打印时又碰一个新问题请您赐教，详情附件！ 0907提取数据并均分为多列.rar (36.72 KB, 下载次数: 5)

2015-9-7 16:11 上传

点击文件名下载附件

grf1973

请看附件。

lidayu

grf1973 发表于 2015-9-8 10:18
请看附件。

您好，感谢您耐心赐教本人感激涕零，完美实现结果。

lidayu

grf1973 发表于 2015-9-8 10:18
请看附件。

grf1973老师您好，之前你帮我完成的作品，因工作需要现在有些小变动，希望能得到您再一次的帮助，详情附件中说明，先谢谢您大师风范无私的帮助！ 0907提取数据并均分为多列.rar (41.37 KB, 下载次数: 6)

2015-12-22 16:03 上传

点击文件名下载附件