提取3列数据拆分为6列

①然如故

不知道为什么 发表于 2018-9-20 21:17
参考

您好，能否直接上传附件，谢谢！

①然如故

不知道为什么 发表于 2018-9-20 22:05
我考虑到你可能后续会提出更多。所以本来想帮你一并全部处理了。
那如果只是那样就更简单了啊

您好，对的只要当第二列满足条件为“丝织警号”就提取对应数据并统计。

不知道为什么

①然如故 发表于 2018-9-20 22:14
您好，对的只要当第二列满足条件为“丝织警号”就提取对应数据并统计。

如图，就是这个意思？

不知道为什么

①然如故 发表于 2018-9-20 22:14
您好，对的只要当第二列满足条件为“丝织警号”就提取对应数据并统计。

      

①然如故

不知道为什么 发表于 2018-9-20 22:18

不知道为什么您好，能不能不把代码转成图片，这样可直接复制工作簿中应用，谢谢！

不知道为什么

①然如故 发表于 2018-9-20 22:23
不知道为什么您好，能不能不把代码转成图片，这样可直接复制工作簿中应用，谢谢！

代码供参考！

1. Sub 拆分2()
   
2.     Dim Arr, Brr(), Crr(), Bt, Ms$
   
3.     Dim i%, x%, n%, s%, n1%, n2%, a%, b&
   
4.     Dim LastRow%, m
   
5.     Application.ScreenUpdating = False
   
6.     Arr = Sheets("数据源").[a1].CurrentRegion
   
7.     Bt = Array("单位名称3", "警号", "数量", "单位名称3", "警号", "数量")
   
8.     Ms = Sheets("丝织警号").Cells(1, 1)
   
9.     ReDim Brr(1 To UBound(Arr), 1 To 6)
   
10.     For i = 2 To UBound(Arr)
    
11.         If Arr(i, 2) = Ms Then
    
12.             x = x + 1
    
13.             Brr(x, 1) = Arr(i, 5)
    
14.             Brr(x, 2) = Arr(i, 9)
    
15.             Brr(x, 3) = Arr(i, 11)
    
16.         End If
    
17.     Next i
    
18.     For i = 1 To x - 1
    
19.         n1 = i: n = i
    
20.         Do While Brr(n1, 1) = Brr(n + 1, 1)
    
21.             n = n + 1
    
22.             s = s + Brr(n, 3)
    
23.             Brr(n, 1) = ""
    
24.         Loop
    
25.         s = s + Brr(n1, 3)
    
26.         Brr(n1, 1) = Brr(n1, 1) & ":" & s
    
27.         i = n
    
28.         s = 0
    
29.     Next i
    
30.     If Brr(x, 1) <> Brr(x - 1, 1) Then Brr(x, 1) = Brr(x, 1) & ":" & Brr(x, 3)
    
31.     ReDim Crr(1 To x, 1 To 6)
    
32.     a = 0: b = 0: n2 = 0
    
33.     For i = 1 To x
    
34.         a = a + 1
    
35.         Crr(a, b + 1) = Brr(i, 1): Crr(a, b + 2) = Brr(i, 2): Crr(a, b + 3) = Brr(i, 3)
    
36.         If a Mod 55 = 0 Then
    
37.             If b = 3 Then
    
38.                 n2 = n2 + 1
    
39.                 a = n2 * 55
    
40.                 b = 0
    
41.             Else
    
42.                 a = n2 * 55
    
43.                 b = 3
    
44.             End If
    
45.         End If
    
46.     Next i
    
47.     LastRow = 55 * (x \ 110) + x Mod 110
    
48.     With Sheets("丝织警号")
    
49.         .[a1].Resize(1, 6).Merge
    
50.         .Range("a2:f9999").Clear
    
51.         .[a2].Resize(1, 6) = Bt
    
52.         .[a3].Resize(LastRow, 6) = Crr
    
53.         With .[a1].Resize(LastRow + 2, 6)
    
54.             .Borders.LineStyle = 1
    
55.             With .Font
    
56.                 .Size = 10
    
57.                 .Name = "宋体"
    
58.             End With
    
59.             .HorizontalAlignment = xlCenter
    
60.             .VerticalAlignment = xlCenter
    
61.             .RowHeight = 14.5
    
62.             m = .Address
    
63.         End With
    
64.         With .Rows(1)
    
65.             .Font.Size = 12
    
66.             .Font.Bold = True
    
67.             .RowHeight = 40
    
68.         End With
    
69.         With .Rows(2)
    
70.             .Font.Size = 12
    
71.             .Font.Bold = True
    
72.             .RowHeight = 22
    
73.         End With
    
74.           For i = 56 To LastRow Step 55  '分页设置 和 打印区域
    
75.         '设置很耗时间演示中我就注释掉了
    
76.            .Rows(i).PageBreak = 1
    
77.          Next i
    
78.           .PageSetup.PrintArea = m
    
79.         .Columns.AutoFit
    
80.     End With
    
81.     Sheets("丝织警号").Activate
    
82.     Set Dic = Nothing
    
83.     Application.ScreenUpdating = True
    
84. End Sub
    

复制代码

不知道为什么

①然如故 发表于 2018-9-20 22:23
不知道为什么您好，能不能不把代码转成图片，这样可直接复制工作簿中应用，谢谢！

要等会，代码发出来，系统审核中

①然如故

不知道为什么 发表于 2018-9-20 22:25
要等会，代码发出来，系统审核中

您好，很感谢您耐心的帮助

①然如故

不知道为什么 发表于 2018-9-20 22:25
要等会，代码发出来，系统审核中

不知道为什么

您好，感谢您的帮助，效果基本很好，还有点小问题请您稍作修改，呈上图片。谢谢！
分页符及边框设置